/
Animation.hs
113 lines (90 loc) · 3.79 KB
/
Animation.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
{-----------------------------------------------------------------------------
reactive-banana-wx
Example: A simple animation.
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-}
-- allows pattern signatures like
-- do
-- (b :: Behavior Int) <- stepper 0 ...
{-# LANGUAGE RecursiveDo #-}
-- allows recursive do notation
-- mdo
-- ...
import Graphics.UI.WX hiding (Event, Vector)
import Reactive.Banana
import Reactive.Banana.WX
import Paths (getDataFile)
{-----------------------------------------------------------------------------
Constants
------------------------------------------------------------------------------}
height, width :: Int
height = 400
width = 400
dt :: Double
dt = 20 * ms where ms = 1e-3
sprite :: Bitmap ()
sprite = bitmap $ getDataFile "banana.png"
bitmapWidth, bitmapHeight :: Int
bitmapWidth = 128
bitmapHeight = 128
{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
main :: IO ()
main = start $ do
ff <- frame [ text := "It's functional programming time"
, bgcolor := white
, resizeable := False ]
t <- timer ff [ interval := ceiling (dt * 1e3) ]
pp <- panel ff [ ]
set ff [ layout := minsize (sz width height) $ widget pp ]
-- event network
let networkDescription :: MomentIO ()
networkDescription = mdo
etick <- event0 t command -- frame timer
emouse <- event1 pp mouse -- mouse events
-- mouse pointer position
(bmouse :: Behavior Vector) <-
fmap fromPoint <$> stepper (point 0 0)
(filterJust $ justMotion <$> emouse)
let
-- sprite velocity
bvelocity :: Behavior Vector
bvelocity =
(\pos mouse -> speedup $ mouse `vecSub` pos `vecSub` vec 0 45)
<$> bposition <*> bmouse
where
speedup v = v `vecScale` (vecLengthDouble v / 20)
-- sprite position
(bposition :: Behavior Vector)
<- accumB (vec 0 0) $
(\v pos -> clipToFrame $ (v `vecScale` dt) `vecAdd` pos)
<$> bvelocity <@ etick
let
clipToFrame v = vec
(clip 0 x (fromIntegral $ width - bitmapWidth ))
(clip 0 y (fromIntegral $ height - bitmapHeight))
where
x = vecX v; y = vecY v
clip a x b = max a (min x b)
drawSprite :: Point -> DC a -> b -> IO ()
drawSprite pos dc _view = drawBitmap dc sprite pos True []
-- animate the sprite
sink pp [on paint :== drawSprite . toPoint <$> bposition]
reactimate $ repaint pp <$ etick
network <- compile networkDescription
actuate network
{-----------------------------------------------------------------------------
2D Geometry
------------------------------------------------------------------------------}
type Vector = Vector2 Double
fromPoint :: Point -> Vector
fromPoint pt = vector (fromIntegral (pointX pt)) (fromIntegral (pointY pt))
toPoint :: Vector -> Point
toPoint v = point (ceiling (vecX v)) (ceiling (vecY v))
{-----------------------------------------------------------------------------
wx stuff
------------------------------------------------------------------------------}
justMotion :: EventMouse -> Maybe Point
justMotion (MouseMotion pt _) = Just pt
justMotion _ = Nothing