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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Lazyfoo.Lesson19 (main) where
import Prelude hiding (any, mapM_)
import Control.Monad hiding (mapM_)
import Data.Int
import Data.Maybe
import Data.Monoid
import Foreign.C.Types
import SDL.Vect
import SDL (($=))
import qualified SDL
import qualified Data.Vector as V
import Paths_sdl2 (getDataFileName)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Foldable
#endif
screenWidth, screenHeight :: CInt
(screenWidth, screenHeight) = (640, 480)
joystickDeadZone :: Int16
joystickDeadZone = 8000
data Texture = Texture SDL.Texture (V2 CInt)
loadTexture :: SDL.Renderer -> FilePath -> IO Texture
loadTexture r filePath = do
surface <- getDataFileName filePath >>= SDL.loadBMP
size <- SDL.surfaceDimensions surface
let key = V4 0 maxBound maxBound maxBound
SDL.surfaceColorKey surface $= Just key
t <- SDL.createTextureFromSurface r surface
SDL.freeSurface surface
return (Texture t size)
renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> Maybe CDouble -> Maybe (Point V2 CInt) -> Maybe (V2 Bool) -> IO ()
renderTexture r (Texture t size) xy clip theta center flips =
let dstSize =
maybe size (\(SDL.Rectangle _ size') -> size') clip
in SDL.copyEx r
t
clip
(Just (SDL.Rectangle xy dstSize))
(fromMaybe 0 theta)
center
(fromMaybe (pure False) flips)
textureSize :: Texture -> V2 CInt
textureSize (Texture _ sz) = sz
getJoystick :: IO SDL.Joystick
getJoystick = do
joysticks <- SDL.availableJoysticks
joystick <- if V.length joysticks == 0
then error "No joysticks connected!"
else return (joysticks V.! 0)
SDL.openJoystick joystick
main :: IO ()
main = do
SDL.initialize [SDL.InitVideo, SDL.InitJoystick]
SDL.HintRenderScaleQuality $= SDL.ScaleLinear
do renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $
putStrLn "Warning: Linear texture filtering not enabled!"
window <-
SDL.createWindow
"SDL Tutorial"
SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight}
SDL.showWindow window
renderer <-
SDL.createRenderer
window
(-1)
SDL.RendererConfig
{ SDL.rendererType = SDL.AcceleratedVSyncRenderer
, SDL.rendererTargetTexture = False
}
SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound
arrowTexture <- loadTexture renderer "examples/lazyfoo/arrow.bmp"
joystick <- getJoystick
joystickID <- SDL.getJoystickID joystick
let loop (xDir', yDir') = do
events <- SDL.pollEvents
let (Any quit, Last newDir) =
foldMap (\case
SDL.QuitEvent -> (Any True, mempty)
SDL.KeyboardEvent e ->
if | SDL.keyboardEventKeyMotion e == SDL.Pressed ->
case SDL.keysymScancode (SDL.keyboardEventKeysym e) of
SDL.ScancodeEscape -> (Any True, mempty)
_ -> mempty
| otherwise -> mempty
SDL.JoyAxisEvent e ->
if | SDL.joyAxisEventWhich e == joystickID ->
(\x -> (mempty, Last $ Just x)) $
case SDL.joyAxisEventAxis e of
0 -> if | SDL.joyAxisEventValue e < -joystickDeadZone -> (-1, yDir')
| SDL.joyAxisEventValue e > joystickDeadZone -> (1, yDir')
| otherwise -> (0, yDir')
1 -> if | SDL.joyAxisEventValue e < -joystickDeadZone -> (xDir', -1)
| SDL.joyAxisEventValue e > joystickDeadZone -> (xDir', 1)
| otherwise -> (xDir', 0)
_ -> (xDir', yDir')
| otherwise -> mempty
_ -> mempty) $
map SDL.eventPayload events
SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound
SDL.clear renderer
let dir@(xDir, yDir) = fromMaybe (xDir', yDir') newDir
phi = if xDir == 0 && yDir == 0
then 0
else atan2 yDir xDir * (180.0 / pi)
renderTexture renderer arrowTexture (P (fmap (`div` 2) (V2 screenWidth screenHeight) - fmap (`div` 2) (textureSize arrowTexture))) Nothing (Just phi) Nothing Nothing
SDL.present renderer
unless quit $ loop dir
loop (0, 0)
SDL.closeJoystick joystick
SDL.destroyRenderer renderer
SDL.destroyWindow window
SDL.quit
|
