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
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
|
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE StandaloneDeriving #-}
import Prelude hiding ((.), id, null, filter)
import Data.Time.Clock
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, filter, groupBy, length, reverse, sort)
import GHC.Word
import Data.Bits
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Graphics.UI.SDL.Utilities as SDL.Util
import qualified Data.Map as Map
smartShowPitch p = showPitch p -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars
_USE_HEXAGONS = True
_LABEL_WHILE_PLAYING = True
_LABEL_ALL_KEYS = False
_AXIS_ROWS = 7 + 4
_AXIS_UNIQUE_COLS = 7
_AXIS_COLS_REPEAT = 2
_AXIS_TOPLEFT_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2)
_AXIS_BOTTOMLEFT_PITCH = _AXIS_TOPLEFT_PITCH - (_AXIS_ROWS * 7)
_AXIS_TOPRIGHT_PITCH = _AXIS_TOPLEFT_PITCH + _AXIS_UNIQUE_COLS `div` 2
--_KEY_BORDER_COLOR = (SDL.Color 0 0 255)
_KEY_BORDER_COLOR = (SDL.Color 0 0 0)
_KEY_ON_COLOR = (SDL.Color 0xAA 0x00 0xFF)
_KB_BG_COLOR = (SDL.Color 0 0 0)
_KEY_TEXT_COLOR = (SDL.Color 128 128 0)
_KEY_BORDER_COLOR_PIXEL = colorToPixel _KEY_BORDER_COLOR
_KB_BG_COLOR_PIXEL = colorToPixel _KB_BG_COLOR
{-
http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter
0 – black (#000000) 000000 0
1 – blue (#0000AA) 000001 1
2 – green (#00AA00) 000010 2
3 – cyan (#00AAAA) 000011 3
4 – red (#AA0000) 000100 4
5 – magenta (#AA00AA) 000101 5
6 – brown (#AA5500) 010100 20
7 – white / light gray (#AAAAAA) 000111 7
8 – dark gray / bright black (#555555) 111000 56
9 – bright blue (#5555FF) 111001 57
10 – bright green (#55FF55) 111010 58
11 – bright cyan (#55FFFF) 111011 59
12 – bright red (#FF5555) 111100 60
13 – bright magenta (#FF55FF) 111101 61
14 – bright yellow (#FFFF55) 111110 62
15 – bright white (#FFFFFF) 111111 63
-}
_CGA = [ (SDL.Color 0x00 0x00 0x00), --black
(SDL.Color 0x00 0x00 0xAA), --blue
(SDL.Color 0x00 0xAA 0x00), --green
(SDL.Color 0x00 0xAA 0xAA), --cyan
(SDL.Color 0xAA 0x00 0x00), --red
(SDL.Color 0xAA 0x00 0xAA), --magenta
(SDL.Color 0xAA 0x55 0x00), --brown
(SDL.Color 0xAA 0xAA 0xAA), --white / light gray
(SDL.Color 0x55 0x55 0x55), --dark gray / bright black
(SDL.Color 0x55 0x55 0xFF), --bright blue
(SDL.Color 0x55 0xFF 0x55), --bright green
(SDL.Color 0x55 0xFF 0xFF), --bright cyan
(SDL.Color 0xFF 0x55 0x55), --bright red
(SDL.Color 0xFF 0x55 0xFF), --bright magenta
(SDL.Color 0xFF 0xFF 0x55), --bright yellow
(SDL.Color 0xFF 0xFF 0xFF)] --bright white
_CHAN_TO_COLOR = _KEY_ON_COLOR : (tail _CGA)
_drawHexircle f v x y s c =
if _USE_HEXAGONS
then _drawHexagonSDL f v x y s c
else (if f then SDL.Primitive.filledCircle else SDL.Primitive.circle) v x y (s * 7 `div` 9) c
drawHexircle = _drawHexircle False
drawFilledHexircle = _drawHexircle True
colorToPixel x = let (SDL.Color r g b) = x in rgbColor r g b
inMajorC pclass = not (pclass == 1 || pclass == 3 || pclass == 6 || pclass == 8 || pclass == 10)
-- TODO: color schemes with per-key {bg, border, hilightcolor, textcolor}
-- TODO: try hilighting like in the app, where only part of the key is colored
-- TODO: idea: for the channels, draw a dot. offset the dot from the center of the key at an angle determined by the channel number
pitchToColor p =
case p `mod` 12 of
2 -> (SDL.Color 0xC0 0xC0 0xFF) -- D
8 -> (SDL.Color 0x33 0x33 0x66) -- G#
x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7
_ -> _CGA !! 8
smartDrawKeys :: (Enum a, Integral a1, Integral a3, Integral a2, Num a) => a -> Bool -> Set.Set (Event.Channel, Event.Pitch) -> Set.Set (Event.Channel, Event.Pitch) -> SDL.Surface -> SDL.TTF.Font -> [(a2, a3)] -> a1 -> IO ()
smartDrawKeys colsRepeat reallyErase beforeKeys_ nowKeys_ videoSurface font axis_key_locations axis_key_size = do
let
chanfilter = Set.filter (\ (c, _) -> c /= (Event.Channel 9))
beforeKeys = chanfilter beforeKeys_
nowKeys = chanfilter nowKeys_
changedPitches = Set.map (\ (_, p) -> p) $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys)
playingNowChans n = Set.map (\ (c, _) -> c) $ Set.filter (\ (_, p) -> p == n) nowKeys
actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches
forM_ actions $ \ (n, chans) -> do
let text = smartShowPitch (unPitch n)
pitch = unPitch n
indices = elemIndices pitch $ pitchIndex colsRepeat
off = length chans == 0
forM_ indices $ \idx -> do
let showLabel = (not reallyErase) && (_LABEL_ALL_KEYS || (_LABEL_WHILE_PLAYING && (not off)))
drawKey idx videoSurface font axis_key_locations axis_key_size
(if reallyErase then _KB_BG_COLOR else pitchToColor pitch)
(if showLabel then (Just text) else Nothing)
chans
allKeysOff colsRepeat reallyErase videoSurface font axis_key_locations axis_key_size = do
let indices = [0 .. length axis_key_locations - 1]
showLabel = (not reallyErase) && _LABEL_ALL_KEYS
forM_ indices $ \idx -> do
let pitch = pitchIndex colsRepeat !! idx
bgColor = if reallyErase then _KB_BG_COLOR else pitchToColor pitch
text = smartShowPitch pitch
label = (if showLabel then (Just text) else Nothing)
drawKey idx videoSurface font axis_key_locations axis_key_size bgColor label []
-- OK, what we need to do now...
-- 1. change smartDrawKeys to take key locations instead of midi events; these are channel/location pairs
-- 2. change the main loop to calculate the key locations, per channel, by choosing the location closest to the average from the last N locations
-- That should be accomplished through a Data.Map mapping from each channel to a Data.Queue of locations
-- Note that this data needs to be thrown out if the size of the keyboard changes.
-- The data should also be thrown out if it gets too old; if the channel isn't being used
-- The algorithm to choose can be stupid (just use the average), because
-- the goal is just to get the code organized so that it has the
-- previous locations available to make a choice. But a smart algorithm
-- would choose based on the "structure" of the actual music.
-- Question: how to deal with simultaneous keypresses?
-- Next order of business:
--drawKey :: (Integral a1, Integral a2, Integral a) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> t -> Maybe String -> [Int] -> IO ()
drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text channels = do
let (x, y) = axis_key_locations !! idx
drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor)
let len = length channels
let channels' = sort channels
Control.Monad.when (len /= 0) $ do
forM_ [0 .. len - 1] $ \i -> do
let (x', y') = if len == 1 then (0, 0)
else (d * cos(2*pi/lenf * ifi), d * sin(2*pi/lenf * ifi))
ifi = fromIntegral i
lenf = fromIntegral len
d = (fromIntegral axis_key_size) / 4 :: Float
r' = (fromIntegral axis_key_size) / 2 :: Float
x'' = (round x') + (fromIntegral x)
y'' = (round y') + (fromIntegral y)
chan = channels' !! i
color = _CHAN_TO_COLOR !! fromIntegral(unChannel chan)
SDL.Primitive.filledCircle videoSurface x'' y'' (round r') (colorToPixel color)
case text of
(Just t) -> centerText videoSurface x y font _KEY_TEXT_COLOR fillColor t
_ -> return ()
fi = fromIntegral
rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. (fi 255))
chooseFontSize h w = 30 * d `div` 1024 where d = min h w
data LoopState = LoopState {
firstLoop :: Bool,
repeatCols :: Integer
} deriving (Show)
_SDL_DIGITS = Set.fromList [SDL.SDLK_1, SDL.SDLK_2, SDL.SDLK_3, SDL.SDLK_4, SDL.SDLK_5, SDL.SDLK_6, SDL.SDLK_7, SDL.SDLK_8, SDL.SDLK_9, SDL.SDLK_0]
firstDigitDown :: Set.Set SDL.Keysym.SDLKey -> Maybe Integer
firstDigitDown k = if Set.null digitsDown then Nothing else Just $ (-48 +) $ fromIntegral $ SDL.Util.fromEnum $ Set.findMin digitsDown
where digitsDown = Set.intersection _SDL_DIGITS k
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 sWidth = SDL.videoInfoWidth info
sHeight = SDL.videoInfoHeight info
warpMouse = do
_ <- SDL.warpMouse (fromIntegral (sWidth `div` 2)) (fromIntegral (sHeight `div` 2))
return ()
setVideoMode w h = SDL.setVideoMode w h 32 [SDL.HWSurface, SDL.Resizable, SDL.DoubleBuf]
_ <- setVideoMode sWidth sHeight
_ <- SDL.TTF.init
font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" (chooseFontSize sWidth sHeight)
--_ <- SDL.showCursor False
--_ <- SDL.grabInput True
--warpMouse
-- _ <- SDL.setRelativeMouseMode True -- SDL2. Should I use it?
-- using the pixelFormat methods gives the wrong color, with both the
-- real pixelFormat or the faked one, so fuck it. See colorToPixel
--let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
--pixelFormat <- SDL.surfaceGetPixelFormat <$> SDL.createRGBSurfaceEndian [] 1 1 24
putStrLn "Initialized."
let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr)
let loop state midiKeysDown keysDown resolution font = do
let (LoopState firstLoop colsRepeat) = state
(keysDown', resolution') <- parseSDLEvents keysDown resolution
midiKeysDown' <- parseAlsa midiKeysDown
let colsRepeat' = case firstDigitDown keysDown' of Nothing -> colsRepeat; (Just 0) -> colsRepeat; (Just n) -> n;
let restartVideo = resolution' /= resolution || colsRepeat' /= colsRepeat
Control.Monad.when restartVideo $ do
let (w, h) = resolution'
_ <- setVideoMode w h
return ()
let (w, h) = resolution'
fontSize = chooseFontSize w h
font' <- (if (restartVideo) then SDL.TTF.openFont "LiberationMono-Bold.ttf" fontSize else return font)
videoSurface <- SDL.getVideoSurface
videoClipRect <- SDL.getClipRect videoSurface
let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat' videoClipRect
let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOMLEFT_PITCH .. _AXIS_TOPRIGHT_PITCH]
keysOFF really = allKeysOff colsRepeat' really videoSurface font' axis_key_locations axis_key_size
allKeysOFF = keysOFF False
allKeysReallyOFF = keysOFF True
Control.Monad.when(firstLoop) allKeysOFF
-- Control.Monad.when (x /= x' && x' /= "") $ do
-- textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x'
-- return ()
let
chanfilter = Set.filter (\ (c, _) -> c /= (Event.Channel 9))
beforeKeys = chanfilter midiKeysDown
nowKeys = chanfilter midiKeysDown'
changedPitches = Set.map (\ (_, p) -> p) $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys)
playingNowChans n = Set.map (\ (c, _) -> c) $ Set.filter (\ (_, p) -> p == n) nowKeys
actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches
chanPitches = Map.fromListWith (++) $ map (\ (c, p) -> (c, [p])) $ Set.toList nowKeys
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
smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size
return ()
Control.Monad.when (restartVideo) $ do
allKeysOFF
smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size
return ()
Control.Monad.when (keysDown' /= keysDown) $ do
Control.Monad.when (keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF
Control.Monad.when (keyDown SDL.SDLK_c keysDown') allKeysReallyOFF
-- 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.flip videoSurface
let framerate = 30
let delay = 1000 `div` framerate -- TODO: subtract delta
SDL.delay (delay)
Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $
loop (LoopState False colsRepeat') midiKeysDown' keysDown' resolution' font'
loop (LoopState True _AXIS_COLS_REPEAT) Set.empty Set.empty (sWidth, sHeight) font
zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls)
drawHexagonSDL = _drawHexagonSDL False
drawFilledHexagonSDL = _drawHexagonSDL True
_drawHexagonSDL filled videoSurface centerx centery radius pixel = do
let r = fromIntegral radius
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]
(if not filled then SDL.Primitive.polygon else SDL.Primitive.filledPolygon) videoSurface points pixel
centerText videoSurface x y font fgColor bgColor 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 fgColor bgColor
fontSurface <- SDL.TTF.renderUTF8Blended font text fgColor
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 ()
pitchIndex colsRepeat = concat $ map (\x -> unique) [0 .. colsRepeat - 1]
where
toprow = map (\i -> if (i `mod` 2) == 0 then (_AXIS_TOPLEFT_PITCH + i `div` 2) else (_AXIS_TOPLEFT_PITCH - 3 + i `div` 2)) [0 .. _AXIS_UNIQUE_COLS - 1]
colfrom top = map (+ top) $ map (* (-7)) [0 .. _AXIS_ROWS - 1]
unique = concat $ map colfrom toprow
getKeyLocations colsRepeat (SDL.Rect offx offy totalw totalh) =
let (key_height, key_width, xys) = getKeyLocationsAbs colsRepeat
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 colsRepeat =
let kb_rows = (fromIntegral _AXIS_ROWS) :: Double
kb_cols = (fromIntegral colsRepeat) * (fromIntegral _AXIS_UNIQUE_COLS) :: 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 ->
let repetition = i `div` fromIntegral(_AXIS_UNIQUE_COLS)
odd = 1 == i `mod` 2
dropBy = if odd then kh / 2 + kh * fromInteger(repetition `div` 2)
else kh * fromInteger((repetition + 1) `div` 2)
in
(
fromInteger(i) * kw * 3 / 4,
y + dropBy
)) [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 SDLKey -> (Int, Int) -> IO (Set.Set SDLKey, (Int, Int))
parseSDLEvents keysDown others = do
event <- SDL.pollEvent
case event of
SDL.NoEvent -> return (keysDown, others)
SDL.KeyDown (SDL.Keysym k _ _) -> parseSDLEvents (Set.insert k keysDown) others
SDL.KeyUp (SDL.Keysym k _ _) -> parseSDLEvents (Set.delete k keysDown) others
SDL.VideoResize w h -> parseSDLEvents keysDown (w, h)
_ -> parseSDLEvents keysDown others
keyDown :: SDL.Keysym.SDLKey -> Set.Set SDL.Keysym.SDLKey -> Bool
keyDown k s = Set.member k s
deriving instance Ord SDL.Keysym
|