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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
{-# 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
import Graphics.UI.SDL.Primitives as SDL.Primitive
import Data.Int (Int16)
import qualified System.Exit as Exit
import Data.List (elemIndex, elemIndices)
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]
_ <- 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
let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue???
-- _ <- SDL.setRelativeMouseMode True -- SDL2. Should I use it?
let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect
forM_ axis_key_locations $ \(x, y) -> do
--SDL.Primitive.filledCircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return
drawHexagonSDL videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return
forM_ [0 .. length axis_key_locations - 1] $ \i -> do
let (centerx, centery) = axis_key_locations !! i
centerText videoSurface centerx centery font (showPitch $ pitchIndex !! i)
-- centerText videoSurface centerx centery font (show i)
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
textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x'
return ()
Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do
--let chord = showChord midiKeysDown'
--let chord = show $ pitchList midiKeysDown'
let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown'
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'
textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord
textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $
if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else ""
return ()
Control.Monad.when(False) $ do
mouse <- SDL.getRelativeMouseState
let (x, y, button) = mouse
let text = ((show x) ++ " " ++ (show y) ++ " " ++ (show button))
textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font text
Control.Monad.when (x /= 0 || y /= 0) warpMouse
_ <- SDL.updateRect videoSurface videoClipRect -- draw it all! probably a bad idea
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 ""
zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls)
drawHexagonSDL videoSurface centerx centery radius pixel = do
let r = fromIntegral radius
--let points = map (\(x, y) -> (centerx + x + radius `div` 2, centery + y + radius `div` 2)) $
let points = map (\(x, y) -> (centerx + x, centery + y)) $
map (\(x, y) -> (round x, round y)) $
map (\i -> (r * cos(pi/3 * (i)), r * sin(pi/3 * (i)))) $ map fromIntegral [0 .. 5]
--filledPolygon :: Surface -> [(Int16, Int16)] -> Pixel -> IO Bool
SDL.Primitive.polygon videoSurface points pixel >>= return
return ()
centerText videoSurface x y font text = do
--fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) -- useful for testing
fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 0 0 0)
fontClipRect <- SDL.getClipRect fontSurface
let (SDL.Rect _ _ w h) = fontClipRect
_ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h))
return ()
colfrom top = map (+ top) $ map (* (-7)) [0 .. 6]
pitchIndex = (\x -> x ++ x) $ concat $ map colfrom [81, 78, 82, 79, 83, 80, 84]
getKeyLocations (SDL.Rect offx offy totalw totalh) =
let (key_height, key_width, xys) = getKeyLocationsAbs
screenw = fromIntegral(totalw)
screenh = fromIntegral(totalh)
kb_rows = length xys
kb_cols = length (head xys)
-- there are 14 keys (13 steps) from the far left to the far right of the axis; if the radius is 1 each step is 1.5 horizontal, plus 2 halfs to fill to the edges
-- thus the keyboard is radius * ((numkeys - 1) * 1.5 + 2)
keyboard_width = (fromIntegral(kb_cols - 1) * 1.5 + 2) * key_width / 2
keyboard_height = fromIntegral(kb_rows + 1) * key_height -- half of the keyboard is offset down one key
fit_width = screenh / screenw > keyboard_height / keyboard_width
scale = if fit_width
then screenw / keyboard_width
else screenh / keyboard_height
kh = key_height * scale
kw = key_width * scale
centerx = (screenw - keyboard_width * scale) / 2
centery = (screenh - keyboard_height * scale) / 2
in
(floor(kw/2 * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw/2), floor(scale * y + centery + kh/2))) $ concat $ zipzip xys)
getKeyLocationsAbs =
let kb_rows = 7 :: Double
kb_cols = 14 :: Double
-- the edges of the hexagon are equal in length to its "radius"
-- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next
-- or else it is 2*sqrt(3) to move down
kw = 1 :: Double
kh = kw/2 * sqrt(3) -- hexagon ratio
xys =
map (\y -> map (\i -> (
fromInteger(i) * kw * 3 / 4,
y + kh / 2 * fromInteger(i `mod` 2) +
(if (fromInteger(i) >= kb_cols / 2) then kh * fromInteger((i+1) `mod` 2) else 0)
)) [0 .. round(kb_cols) - 1]) $
map (\i -> kh * fromIntegral(i))
[0..round(kb_rows) - 1]
in
(kh, kw, xys)
-- 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
|
