-
Notifications
You must be signed in to change notification settings - Fork 5
/
Input.hs
101 lines (88 loc) · 2.87 KB
/
Input.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
{-# LANGUAGE RankNTypes, Arrows #-}
module Input where
import Prelude hiding ((.), id)
import Control.Category
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Graphics.UI.GLFW as G
import Control.Wire.Core
import FRP.Netwire
import Control.Wire.Unsafe.Event (Event(..))
type Input a = (HasTime t s, MonadIO m) => Wire s () (ReaderT Window m) () a
data Moving = ML | MR deriving Eq
data Rotating = CW | CCW deriving Eq
data InputData = InputData {
inputdataMoving :: Event (Maybe Moving)
, inputdataRotating :: Event (Maybe Rotating)
, inputdataQuickFall :: Event ()
, inputdataSlowFall :: Bool
, inputdataHold :: Event ()
}
processInput :: (HasTime t s, MonadIO m) => Window -> Input a -> Wire s () m () a
processInput w i = mapWire (\r -> runReaderT r w) i
inputWire :: Input InputData
inputWire = InputData <$> movingWire <*> rotatingWire <*> quickFallWire <*> slowFallWire <*> holdWire
movingWire :: Input (Event (Maybe Moving))
movingWire =
let io = mkGen_ $ \_ -> do
w <- ask
left <- liftIO $ getKey w Key'Left
right <- liftIO $ getKey w Key'Right
return . Right $ case (left, right) of
(KeyState'Pressed, _) -> Just ML
(_, KeyState'Pressed) -> Just MR
_ -> Nothing
in (proc _ -> do
mm <- io -< ()
dmm <- delay Nothing <<< io -< ()
let emm = if dmm /= mm then Event mm else NoEvent
returnA -< emm)
slowFallWire :: Input Bool
slowFallWire = mkGen_ $ \_ -> do
w <- ask
f <- liftIO $ getKey w Key'Down
return . Right $ case f of
KeyState'Released -> False
_ -> True
quickFallWire :: Input (Event ())
quickFallWire =
let io = mkGen_ $ \_ -> do
w <- ask
d <- liftIO $ getKey w Key'Space
return . Right $ case d of
KeyState'Pressed -> True
_ -> False
in proc _ -> do
mf <- io -< ()
dmf <- delay False <<< io -< ()
let emf = if dmf /= mf && mf /= False then Event () else NoEvent
returnA -< emf
holdWire :: Input (Event ())
holdWire =
let io = mkGen_ $ \_ -> do
w <- ask
l <- liftIO $ getKey w Key'LeftShift
r <- liftIO $ getKey w Key'RightShift
return . Right $ case (l,r) of
(KeyState'Pressed,_) -> True
(_,KeyState'Pressed) -> True
_ -> False
in proc _ -> do
mf <- io -< ()
dmf <- delay False <<< io -< ()
let emf = if dmf /= mf && mf /= False then Event () else NoEvent
returnA -< emf
rotatingWire :: Input (Event (Maybe Rotating))
rotatingWire =
let io = mkGen_ $ \_ -> do
w <- ask
cw <- liftIO $ getKey w Key'Up
return . Right $ case cw of
KeyState'Pressed -> Just CW
_ -> Nothing
in proc _ -> do
mr <- io -< ()
dmr <- delay Nothing <<< io -< ()
let emr = if dmr /= mr then Event mr else NoEvent
returnA -< emr