-
Notifications
You must be signed in to change notification settings - Fork 0
/
Input.hs
107 lines (99 loc) · 3.72 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
102
103
104
105
106
107
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Sample.Bezier.Input
( getSamples
, newState
, deCasteljau
) where
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State
import Data.Array.IO
import Data.Int
import qualified Data.Vector as V
import GHC.Real (Ratio (..))
import SDL
import SDL.Vect (Point (..), V2 (..))
import Sample.Bezier.Types
newState :: Integer -> Integer -> IO DrawState
newState ht wt = return DT {height = ht, width = wt, samples = V.empty}
getSamples :: DrawState -> IO Sample
getSamples ds = do
window <-
createWindow
"Draw Timbre Shape"
defaultWindow
{ windowInitialSize =
V2 (fromIntegral $ width ds) (fromIntegral $ height ds)
, windowHighDPI = True
}
renderer <- createRenderer window (-1) defaultRenderer
samples <$> execStateT (renderLoop renderer) ds
deCasteljau :: RealFrac a => a -> [Point V2 a] -> Point V2 a
deCasteljau t [b] = b
deCasteljau t coefs = deCasteljau t reduced
where
reduced = zipWith (lerpP t) coefs (tail coefs)
lerpP t (P (V2 x0 y0)) (P (V2 x1 y1)) = P (V2 (lerp t x0 x1) (lerp t y0 y1))
lerp t a b = t * b + (1 - t) * a
bezierPoint :: (RealFrac a) => a -> DrawT (Point V2 Int32)
bezierPoint t = do
controlPoints <-
Control.Monad.Trans.State.gets
(V.toList . V.map (fromIntegral <$>) . samples)
let res = round <$> deCasteljau t controlPoints
return res
getPosition :: Event -> Maybe (Point V2 Int32)
getPosition (Event _ (MouseButtonEvent (MouseButtonEventData _ Pressed _ ButtonLeft _ pos))) =
return pos
getPosition _ = Nothing
renderLoop :: Renderer -> DrawT ()
renderLoop renderer = do
event <- pollEvent
controlPoints <-
map (fromIntegral <$>) <$>
Control.Monad.Trans.State.gets (V.toList . samples)
ht <- Control.Monad.Trans.State.gets height
wt <- Control.Monad.Trans.State.gets width
rendererDrawColor renderer $= V4 0 0 0 255
clear renderer
rendererDrawColor renderer $= V4 0 0 255 255
drawLine
renderer
(P (V2 0 (div (fromIntegral ht) 4)))
(P (V2 (fromIntegral wt) (div (fromIntegral ht) 4)))
drawLine
renderer
(P (V2 0 (div (3 * fromIntegral ht) 4)))
(P (V2 (fromIntegral wt) (div (3 * fromIntegral ht) 4)))
rendererDrawColor renderer $= V4 0 255 0 255
drawLine
renderer
(P (V2 0 (div (fromIntegral ht) 2)))
(P (V2 (fromIntegral wt) (div (fromIntegral ht) 2)))
rendererDrawColor renderer $= V4 0 255 0 255
mapM_ (drawPoint renderer) controlPoints
rendererDrawColor renderer $= V4 255 0 0 255
vec <- Control.Monad.Trans.State.gets (V.length . samples)
when (vec /= 0) $ do
forM [0.0,0.01 .. 1] bezierPoint >>=
mapM_ (drawPoint renderer . (fromIntegral <$>))
present renderer
maybe (renderLoop renderer) (eventProcess renderer) event
where
eventProcess :: Renderer -> Event -> DrawT ()
eventProcess r (Event _ (KeyboardEvent (KeyboardEventData _ Pressed _ (Keysym _ KeycodeQ _)))) =
return ()
eventProcess r (Event _ (KeyboardEvent (KeyboardEventData _ Pressed _ (Keysym _ KeycodeR _)))) = do
Control.Monad.Trans.State.modify (\x -> x {samples = V.init $ samples x})
renderLoop r
eventProcess r (Event _ (KeyboardEvent (KeyboardEventData _ Pressed _ (Keysym _ KeycodeC _)))) = do
Control.Monad.Trans.State.modify (\x -> x {samples = V.empty})
renderLoop r
eventProcess r e = do
case getPosition e of
Just pos -> do
Control.Monad.Trans.State.modify
(\x -> x {samples = V.snoc (samples x) pos})
Nothing -> return ()
renderLoop r