Skip to content

Commit 2d6f28a

Browse files
ivanperez-keeraivanperez-keera
committed
Aux libs, flappy bird in Yampa
1 parent c7585df commit 2d6f28a

File tree

7 files changed

+365
-1
lines changed

7 files changed

+365
-1
lines changed

‎examples/FlappyBird/FlappyBird.hs

Lines changed: 208 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,208 @@
1+
{-# LANGUAGE Arrows #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE MultiParamTypeClasses #-}
4+
import Control.Applicative
5+
import Control.Arrow
6+
import Control.Monad
7+
import Control.Extra.Monad
8+
import Data.IORef
9+
import FRP.Yampa as Yampa
10+
import FRP.Yampa.Extensions as Yampa
11+
import FRP.Yampa.Backends.SDL as Yampa
12+
import FRP.Yampa.Reactimator as Yampa
13+
import Graphics.UI.SDL as SDL
14+
import Graphics.UI.SDL.Extensions as SDL
15+
import System.Random
16+
17+
main :: IO ()
18+
main = do
19+
20+
-- Sources of randomness, used for the top and bottom bars
21+
stdGen1 <- newStdGen
22+
stdGen2 <- getStdGen
23+
24+
-- Input sensing, time sensing, rendering
25+
(producer, initSample) <- initializeSg :: IO (SDLSignal SDLInput, Controller)
26+
consumer <- initializeSi :: IO MySDLRenderer
27+
28+
-- Reactimation
29+
alwaysReactimate (return initSample)
30+
(pollSg producer)
31+
(pushSi consumer)
32+
(game stdGen1 stdGen2)
33+
34+
-- * Game
35+
36+
game :: StdGen -> StdGen -> SF Controller (Int, ([Int], [Int]))
37+
game stdGen1 stdGen2 = proc (c) -> do
38+
-- (identity &&& allBars) >>> (bird &&& arr snd)
39+
sBars <- allBars -< ()
40+
sBird <- bird -< (c, sBars)
41+
returnA -< (sBird, sBars)
42+
where -- Top bars move slower, bottom bars move faster
43+
allBars = bars stdGen1 &&& timeTransform (*3) (bars stdGen2)
44+
45+
-- Restart every time the bird hits one of the bars
46+
bird :: SF (Controller, ([Int],[Int])) Int
47+
bird = switch
48+
((birdWithinBounds *** identity) >>> (arr fst &&& birdHitBars))
49+
(\_ -> bird)
50+
where birdHitBars = arr birdOnBars >>> edge
51+
birdOnBars (playerY, (barsTop, barsBottom)) =
52+
any (> playerY) selectedTops || any (< playerY) selectedBottoms
53+
where bottomBarTops = map (\x -> height - x - playerHeight) barsBottom
54+
selectedTops = take playerWidth $ drop playerX barsTop
55+
selectedBottoms = take playerWidth $ drop playerX bottomBarTops
56+
57+
-- Restart every time the bird hits the boundaires
58+
birdWithinBounds :: SF Controller Int
59+
birdWithinBounds = switch
60+
(aliveBird >>> (identity &&& hitBounds))
61+
(\_ -> birdWithinBounds) -- Restart from middle of the screen
62+
where hitBounds = arr outOfBounds >>> edge
63+
outOfBounds = ((> height - playerHeight) &&& (< 0)) >>> uncurry (||)
64+
65+
-- Just a falling/rising bird
66+
aliveBird :: SF Controller Int
67+
aliveBird = aliveBird0 (height / 2 :: Double)
68+
69+
aliveBird0 :: Double -> SF Controller Int
70+
aliveBird0 p0 = proc (c) -> do
71+
-- Acceleration up/down depending on input
72+
let acc = if controllerClick c then -stdAcc else stdAcc
73+
-- Otherwise, obey basic physics laws
74+
v <- integral -< acc
75+
p <- (p0 +) ^<< integral -< v
76+
returnA -< round p
77+
78+
bars :: RandomGen g => g -> SF a [Int]
79+
bars g = barSides >>> hold 0 >>> sampleWindow' 0 width 0.1 >>> hold []
80+
where -- Bunch of events carrying random altitudes (at regular times)
81+
barSides :: SF a (Yampa.Event Int)
82+
barSides = (barsUp `rMergeSF` barsDown)
83+
84+
-- Bunch of events, carrying random values (bar heights)
85+
barsUp :: SF a (Yampa.Event Int)
86+
barsUp = (occasionalEvent &&& justNoise) >>> arr (uncurry tag)
87+
88+
-- Bunch of events, carrying zero, at regular times, with a bar width delay
89+
barsDown :: SF a (Yampa.Event Int)
90+
barsDown = barDownSides >>> Yampa.delay barWidth noEvent
91+
where barDownSides :: SF a (Yampa.Event Int)
92+
barDownSides = repeatedly barSep 0
93+
94+
-- Source of random bar sizes
95+
justNoise :: SF a Int
96+
justNoise = noiseR (0, maxBarSize) g
97+
98+
-- Regular separations
99+
occasionalEvent :: SF a (Yampa.Event ())
100+
occasionalEvent = repeatedly barSep ()
101+
102+
-- * App-specific SDL-Yampa bridge
103+
104+
data SDLInput = SDLInput (IORef Controller)
105+
106+
-- | Controller info at any given point.
107+
data Controller = Controller
108+
{ controllerClick :: Bool }
109+
110+
instance Source SDLInput Controller IO where
111+
112+
initializeSo =
113+
SDLInput <$> newIORef (Controller { controllerClick = False })
114+
115+
pollSo (SDLInput cref) = do
116+
c <- readIORef cref
117+
c' <- sdlGetController c
118+
writeIORef cref c'
119+
return c'
120+
121+
-- We need a non-blocking controller-polling function.
122+
-- TODO: Check http://gameprogrammer.com/fastevents/fastevents1.html
123+
sdlGetController :: Controller -> IO Controller
124+
sdlGetController info =
125+
foldWhileM info pollEvent (not.isEmptyEvent) ((return .) . handleEvent)
126+
127+
-- | Handles one event only and returns the updated controller.
128+
handleEvent :: Controller -> SDL.Event -> Controller
129+
handleEvent c e =
130+
case e of
131+
MouseButtonDown _ _ ButtonLeft -> c { controllerClick = True }
132+
MouseButtonUp _ _ ButtonLeft -> c { controllerClick = False}
133+
KeyDown (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = True }
134+
KeyUp (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = False }
135+
_ -> c
136+
137+
-- ** SDL renderer as Yampa output consumer (sink)
138+
data MySDLRenderer = MySDLRenderer
139+
140+
instance Sink MySDLRenderer (Int, ([Int],[Int])) IO where
141+
142+
-- Initialize renderer
143+
initializeSi = do
144+
SDL.init [InitVideo]
145+
146+
_screen <- setVideoMode width height bpp [SWSurface]
147+
148+
setCaption "Test" ""
149+
150+
enableUnicode True
151+
152+
return MySDLRenderer
153+
154+
-- Rendering each frame
155+
pushSi MySDLRenderer (playerY, (ceilingHeights,floorHeights)) = do
156+
screen <- getVideoSurface
157+
158+
let format = surfaceGetPixelFormat screen
159+
160+
-- Background
161+
green <- mapRGB format 0 0xFF 0
162+
_ <- fillRect screen Nothing green
163+
164+
-- Paint bars
165+
red <- mapRGB format 0xFF 0 0
166+
let paintTopBar (x,h) = fillRect screen (Just (Rect x (height - h) 1 h)) red
167+
paintBotBar (x,h) = fillRect screen (Just (Rect x 0 1 h)) red
168+
mapM_ paintBotBar (zip [0 .. width-1] ceilingHeights)
169+
mapM_ paintTopBar (zip [0 .. width-1] floorHeights)
170+
171+
-- Paint player
172+
blue <- mapRGB format 0 0 0xFF
173+
_ <- fillRect screen (Just $ Rect playerX playerY playerWidth playerHeight) blue
174+
175+
SDL.flip screen
176+
177+
-- * Game settings
178+
-- Configuration parameters
179+
width :: Num a => a
180+
width = 640
181+
182+
height :: Num a => a
183+
height = 480
184+
185+
bpp :: Num a => a
186+
bpp = 16
187+
188+
-- Settings
189+
maxBarSize :: Num a => a
190+
maxBarSize = 200
191+
192+
-- barSep :: Num a => a
193+
barSep = 20
194+
195+
barWidth :: Num a => a
196+
barWidth = 5
197+
198+
playerHeight :: Num a => a
199+
playerHeight = 32
200+
201+
playerWidth :: Num a => a
202+
playerWidth = 32
203+
204+
playerX :: Num a => a
205+
playerX = 300
206+
207+
stdAcc :: Double
208+
stdAcc = 9.8

‎haskell-game-programming.cabal

Lines changed: 18 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ build-type: Simple
1616
extra-source-files: README.md
1717
cabal-version: >=1.10
1818

19-
executable raindrops
19+
executable example-raindrops
2020
main-is: Raindrops.hs
2121
-- other-modules:
2222
hs-source-dirs: examples/raindrops/
@@ -34,6 +34,22 @@ executable raindrops
3434
-- hs-source-dirs:
3535
default-language: Haskell2010
3636

37+
executable example-flappybird
38+
main-is: FlappyBird.hs
39+
-- other-modules:
40+
hs-source-dirs: examples/FlappyBird/ examples/ libraries
41+
-- other-extensions: Arrows, FlexibleInstances, MultiParamTypeClasses,
42+
-- TypeSynonymInstances, FlexibleContexts,
43+
-- FunctionalDependencies, MultiWayIf
44+
build-depends: base,
45+
containers,
46+
random,
47+
Yampa,
48+
SDL,
49+
SDL-ttf
50+
-- hs-source-dirs:
51+
default-language: Haskell2010
52+
3753
executable animation-frames
3854
main-is: Main.hs
3955
hs-source-dirs: tutorials/gameconcepts/multimedia/animation/
@@ -199,3 +215,4 @@ executable sdl-sdl1-time-example3
199215
SDL-gfx
200216
-- hs-source-dirs:
201217
default-language: Haskell2010
218+

‎libraries/Control/Extra/Monad.hs

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
module Control.Extra.Monad where
2+
3+
import Control.Monad
4+
5+
whileLoopM :: Monad m => m a -> (a -> Bool) -> (a -> m ()) -> m ()
6+
whileLoopM val cond act = r'
7+
where r' = do v <- val
8+
when (cond v) $ do
9+
act v
10+
whileLoopM val cond act
11+
12+
foldWhileM :: Monad m => a -> m b -> (b -> Bool) -> (a -> b -> m a) -> m a
13+
foldWhileM val sense cond act = r'
14+
where r' = do s <- sense
15+
if cond s
16+
then do
17+
val' <- act val s
18+
foldWhileM val' sense cond act
19+
else return val

‎libraries/FRP/Yampa/Backends/SDL.hs

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
{-# LANGUAGE MultiParamTypeClasses #-}
2+
{-# LANGUAGE FunctionalDependencies #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE UndecidableInstances #-}
6+
{-# LANGUAGE FlexibleInstances #-}
7+
module FRP.Yampa.Backends.SDL where
8+
9+
import Data.IORef
10+
import FRP.Yampa.Signal as Yampa
11+
import Graphics.UI.SDL as SDL
12+
13+
-- * Signals
14+
15+
-- ** SDL clock as Yampa input (source)
16+
data SDLClock = SDLClock (IORef Int)
17+
18+
instance Signal SDLClock Double IO where
19+
20+
initializeSg = do
21+
timeRef <- newIORef (0 :: Int)
22+
return (SDLClock timeRef, 0)
23+
24+
pollSg (SDLClock timeRef) = do
25+
26+
-- Obtain new number of ticks since initialisation
27+
ts <- fmap fromIntegral getTicks
28+
29+
-- Calculate time delta
30+
pt <- readIORef timeRef
31+
let dt = ts - pt
32+
dtY = fromIntegral dt / 100
33+
34+
-- Update number of tickts
35+
writeIORef timeRef ts
36+
37+
-- Return time delta as floating point number
38+
return (dtY, dtY)
39+
40+
data SDLSignal a = SDLSignal
41+
{ sdlClock :: SDLClock
42+
, sdlValue :: a
43+
}
44+
45+
instance Source a v IO => Signal (SDLSignal a) v IO where
46+
initializeSg = do
47+
(clk,_) <- initializeSg
48+
so <- initializeSo
49+
c <- pollSo so
50+
return (SDLSignal clk so, c)
51+
52+
-- Sense new input
53+
pollSg (SDLSignal clock input) = do
54+
(dt,_) <- pollSg clock
55+
c' <- pollSo input
56+
return (dt, c')

‎libraries/FRP/Yampa/Extensions.hs

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
module FRP.Yampa.Extensions where
2+
3+
import FRP.Yampa as Yampa
4+
5+
-- * FRP Extensions
6+
rMergeSF :: SF a (Yampa.Event b) -> SF a (Yampa.Event b) -> SF a (Yampa.Event b)
7+
rMergeSF = lift2 rMerge
8+
9+
lift2 :: (b -> c -> d) -> SF a b -> SF a c -> SF a d
10+
lift2 f sf1 sf2 = (sf1 &&& sf2) >>> arr (uncurry f)
11+
12+
-- Taken and modified from the original Yampa code
13+
sampleWindow' :: a -> Int -> Time -> SF a (Yampa.Event [a])
14+
sampleWindow' def wl q =
15+
identity &&& afterEachCat (repeat (q, ()))
16+
>>> arr (\(a, e) -> fmap (map (const a)) e)
17+
>>> accumBy updateWindow (take wl $ repeat def)
18+
where
19+
updateWindow w as = drop (max (length w' - wl) 0) w'
20+
where w' = w ++ as

‎libraries/FRP/Yampa/Reactimator.hs

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
module FRP.Yampa.Reactimator where
2+
3+
import FRP.Yampa as Yampa
4+
5+
-- * Yampa Extensions
6+
7+
-- ** Reactimate forever, obtaining new fresh inputs every time
8+
alwaysReactimate :: IO a -> (IO (DTime, a)) -> (b -> IO ()) -> SF a b -> IO ()
9+
alwaysReactimate initialSense sense consume sf =
10+
reactimate initialSense
11+
(\_ -> do
12+
(dt, sp) <- sense
13+
return (dt, Just sp)
14+
)
15+
(\_ e -> consume e >> return False)
16+
sf
17+
18+
-- -- ** High-level reactimation, from a signal generator to a sink
19+
--
20+
-- {-# LANGUAGE ScopedTypeVariables #-}
21+
--
22+
-- type YampaSystem a b c d = SF c d
23+
--
24+
-- -- I can define the following, but not use it the way I would expect
25+
-- hlReactimate :: forall a b c d . (Signal a c IO, Sink b d IO)
26+
-- => YampaSystem a b c d
27+
-- -> IO ()
28+
-- hlReactimate sf = do
29+
-- (producer, initSample) <- initializeSg :: IO (a, c)
30+
-- consumer <- initializeSi :: IO b
31+
-- alwaysReactimate (return initSample)
32+
-- (pollSg producer)
33+
-- (pushSi consumer)
34+
-- sf

‎libraries/Graphics/UI/SDL/Extensions.hs

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module Graphics.UI.SDL.Extensions where
2+
3+
import Graphics.UI.SDL as SDL
4+
5+
-- ** Auxiliary SDL stuff
6+
7+
-- Auxiliary SDL stuff
8+
isEmptyEvent :: SDL.Event -> Bool
9+
isEmptyEvent SDL.NoEvent = True
10+
isEmptyEvent _ = False

0 commit comments

Comments
 (0)