blob: 5630620cbc94b17d5ef0c40e821a6795ced22076 (
plain)
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
|
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE StandaloneDeriving #-}
import FRP.Netwire hiding (when)
import Prelude hiding ((.), id, null, filter)
import Data.Time.Clock
import Control.Wire hiding (when)
import Control.Wire.Session
import Control.Monad
import qualified Graphics.UI.SDL as SDL
import AlsaSeq
import qualified Data.Set as Set
import qualified Graphics.UI.SDL.TTF as SDL.TTF
import Data.String
import Graphics.UI.SDL.Keysym as SDL.Keysym
netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String
netwireIsCool =
for 2.5 . pure "Once upon a time..." -->
for 3 . pure "... games were completely imperative..." -->
for 2 . pure "... but then..." -->
for 10 . (pure "Netwire 5! " <> anim) -->
netwireIsCool
where
anim =
holdFor 0.5 . periodic 1 . pure "Hoo..." <|>
pure "...ray!"
main =
withAlsaInit $ \h public private q publicAddr privateAddr -> do
cmdlineAlsaConnect h public -- fail early if bad command lines
SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ do
info <- SDL.getVideoInfo
let width = SDL.videoInfoWidth info
height = SDL.videoInfoHeight info
warpMouse = do
_ <- SDL.warpMouse (fromIntegral (width `div` 2)) (fromIntegral (height `div` 2))
return ()
--screen <- SDL.setVideoMode width height 32 [SDL.SWSurface, SDL.Fullscreen]
screen <- SDL.setVideoMode width height 32 [SDL.SWSurface]
_ <- SDL.TTF.init
font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" 30
videoSurface <- SDL.getVideoSurface
videoClipRect <- SDL.getClipRect videoSurface
_ <- SDL.showCursor False
_ <- SDL.grabInput True
warpMouse
-- _ <- SDL.setRelativeMouseMode True -- SDL2. Should I use it?
putStrLn "Initialized."
let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr)
let loop midiKeysDown keysDown s w x = do
keysDown' <- parseSDLEvents keysDown
midiKeysDown' <- parseAlsa midiKeysDown
(ds, s') <- stepSession s
(ex, w') <- stepWire w ds (Right x)
let x' = either (const "") id ex
Control.Monad.when (x /= x' && x' /= "") $ do
putStrLn x'
textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x'
return ()
Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do
let chord = showChord midiKeysDown'
Control.Monad.when (chord /= "") $ putStrLn chord
textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
return ()
Control.Monad.when (keysDown' /= keysDown) $ do
let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown'
Control.Monad.when (chord /= "") $ putStrLn chord
textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord
return ()
mouse <- SDL.getRelativeMouseState
let (x, y, button) = mouse
textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font ((show x) ++ " " ++ (show y) ++ " " ++ (show button))
Control.Monad.when (x /= 0 || y /= 0) warpMouse
_ <- SDL.updateRect videoSurface videoClipRect
let framerate = 30
let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds)
SDL.delay (delay)
Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $
loop midiKeysDown' keysDown' s' w' x'
loop Set.empty Set.empty clockSession_ netwireIsCool ""
-- clear a band the width of the videoClipRect and print the text within it, centered
textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do
let (SDL.Rect vx _ vw _) = videoClipRect
_ <- SDL.fillRect videoSurface (Just (SDL.Rect 0 y vw h)) (SDL.Pixel 0)
Control.Monad.when (text /= "") $ do
fontSurface <- SDL.TTF.renderUTF8Blended font text (SDL.Color 0 255 0)
fontClipRect <- SDL.getClipRect fontSurface
let (SDL.Rect _ fy fw _) = fontClipRect
_ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect ((vw - fw) `div` 2) y vw h))
return ()
return ()
parseSDLEvents :: Set.Set SDL.SDLKey -> IO (Set.Set SDL.Keysym.SDLKey)
parseSDLEvents keysDown = do
event <- SDL.pollEvent
case event of
SDL.NoEvent -> return keysDown
SDL.KeyDown (SDL.Keysym k _ _) -> parseSDLEvents (Set.insert k keysDown)
SDL.KeyUp (SDL.Keysym k _ _) -> parseSDLEvents (Set.delete k keysDown)
_ -> parseSDLEvents keysDown
keyDown :: SDL.Keysym.SDLKey -> Set.Set SDL.Keysym.SDLKey -> Bool
keyDown k s = Set.member k s
deriving instance Ord SDL.Keysym
|
