diff options
-rw-r--r-- | axis.hs | 39 |
1 files changed, 21 insertions, 18 deletions
@@ -41,7 +41,7 @@ _LABEL_ALL_KEYS = False | |||
41 | 41 | ||
42 | _AXIS_ROWS = 7 + 4 | 42 | _AXIS_ROWS = 7 + 4 |
43 | _AXIS_UNIQUE_COLS = 7 | 43 | _AXIS_UNIQUE_COLS = 7 |
44 | _AXIS_COLS_REPEAT = 2 | 44 | _AXIS_COLS_REPEAT = 1 |
45 | _AXIS_TOPLEFT_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2) | 45 | _AXIS_TOPLEFT_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2) |
46 | _AXIS_BOTTOMLEFT_PITCH = _AXIS_TOPLEFT_PITCH - (_AXIS_ROWS * 7) | 46 | _AXIS_BOTTOMLEFT_PITCH = _AXIS_TOPLEFT_PITCH - (_AXIS_ROWS * 7) |
47 | _AXIS_TOPRIGHT_PITCH = _AXIS_TOPLEFT_PITCH + _AXIS_UNIQUE_COLS `div` 2 | 47 | _AXIS_TOPRIGHT_PITCH = _AXIS_TOPLEFT_PITCH + _AXIS_UNIQUE_COLS `div` 2 |
@@ -116,8 +116,8 @@ pitchToColor p = | |||
116 | x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7 | 116 | x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7 |
117 | _ -> _CGA !! 8 | 117 | _ -> _CGA !! 8 |
118 | 118 | ||
119 | smartDrawKeys :: (Integral a, Integral a2, Integral a1) => Bool -> Set.Set (Event.Channel, Event.Pitch) -> Set.Set (Event.Channel, Event.Pitch) -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> IO () | 119 | --smartDrawKeys :: (Integral a, Integral a2, Integral a1) => Bool -> Set.Set (Event.Channel, Event.Pitch) -> Set.Set (Event.Channel, Event.Pitch) -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> IO () |
120 | smartDrawKeys reallyErase beforeKeys_ nowKeys_ videoSurface font axis_key_locations axis_key_size = do | 120 | smartDrawKeys colsRepeat reallyErase beforeKeys_ nowKeys_ videoSurface font axis_key_locations axis_key_size = do |
121 | let | 121 | let |
122 | chanfilter = Set.filter (\ (c, _) -> c /= (Event.Channel 9)) | 122 | chanfilter = Set.filter (\ (c, _) -> c /= (Event.Channel 9)) |
123 | beforeKeys = chanfilter beforeKeys_ | 123 | beforeKeys = chanfilter beforeKeys_ |
@@ -130,7 +130,7 @@ smartDrawKeys reallyErase beforeKeys_ nowKeys_ videoSurface font axis_key_locati | |||
130 | forM_ actions $ \ (n, chans) -> do | 130 | forM_ actions $ \ (n, chans) -> do |
131 | let text = smartShowPitch (unPitch n) | 131 | let text = smartShowPitch (unPitch n) |
132 | pitch = unPitch n | 132 | pitch = unPitch n |
133 | forM_ (elemIndices pitch pitchIndex) $ \idx -> do | 133 | forM_ (elemIndices pitch $ pitchIndex colsRepeat) $ \idx -> do |
134 | let showLabel = (not reallyErase) && (_LABEL_ALL_KEYS || (_LABEL_WHILE_PLAYING && (length chans /= 0))) | 134 | let showLabel = (not reallyErase) && (_LABEL_ALL_KEYS || (_LABEL_WHILE_PLAYING && (length chans /= 0))) |
135 | drawKey idx videoSurface font axis_key_locations axis_key_size | 135 | drawKey idx videoSurface font axis_key_locations axis_key_size |
136 | (if reallyErase then _KB_BG_COLOR else pitchToColor pitch) | 136 | (if reallyErase then _KB_BG_COLOR else pitchToColor pitch) |
@@ -167,7 +167,8 @@ rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi | |||
167 | chooseFontSize h w = 30 * d `div` 1024 where d = min h w | 167 | chooseFontSize h w = 30 * d `div` 1024 where d = min h w |
168 | 168 | ||
169 | data LoopState = LoopState { | 169 | data LoopState = LoopState { |
170 | firstLoop :: Bool | 170 | firstLoop :: Bool, |
171 | repeatCols :: Integer | ||
171 | } deriving (Show) | 172 | } deriving (Show) |
172 | 173 | ||
173 | main = | 174 | main = |
@@ -200,14 +201,16 @@ main = | |||
200 | 201 | ||
201 | let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) | 202 | let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) |
202 | let loop state midiKeysDown keysDown resolution font s w x = do | 203 | let loop state midiKeysDown keysDown resolution font s w x = do |
203 | let (LoopState firstLoop) = state | 204 | let (LoopState firstLoop colsRepeat) = state |
204 | 205 | ||
205 | (keysDown', resolution') <- parseSDLEvents keysDown resolution | 206 | (keysDown', resolution') <- parseSDLEvents keysDown resolution |
206 | midiKeysDown' <- parseAlsa midiKeysDown | 207 | midiKeysDown' <- parseAlsa midiKeysDown |
207 | (ds, s') <- stepSession s | 208 | (ds, s') <- stepSession s |
208 | (ex, w') <- stepWire w ds (Right x) | 209 | (ex, w') <- stepWire w ds (Right x) |
209 | let x' = either (const "") id ex | 210 | let x' = either (const "") id ex |
210 | let restartVideo = resolution' /= resolution | 211 | let colsRepeat' = if (keyDown SDL.SDLK_1 keysDown') then 1 else if (keyDown SDL.SDLK_2 keysDown') then 2 else colsRepeat |
212 | |||
213 | let restartVideo = resolution' /= resolution || colsRepeat' /= colsRepeat | ||
211 | 214 | ||
212 | Control.Monad.when restartVideo $ do | 215 | Control.Monad.when restartVideo $ do |
213 | let (w, h) = resolution' | 216 | let (w, h) = resolution' |
@@ -220,10 +223,10 @@ main = | |||
220 | 223 | ||
221 | videoSurface <- SDL.getVideoSurface | 224 | videoSurface <- SDL.getVideoSurface |
222 | videoClipRect <- SDL.getClipRect videoSurface | 225 | videoClipRect <- SDL.getClipRect videoSurface |
223 | let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect | 226 | let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat' videoClipRect |
224 | 227 | ||
225 | let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOMLEFT_PITCH .. _AXIS_TOPRIGHT_PITCH] | 228 | let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOMLEFT_PITCH .. _AXIS_TOPRIGHT_PITCH] |
226 | keysOFF really = smartDrawKeys really _ALL_PITCHES Set.empty videoSurface font' axis_key_locations axis_key_size | 229 | keysOFF really = smartDrawKeys colsRepeat' really _ALL_PITCHES Set.empty videoSurface font' axis_key_locations axis_key_size |
227 | allKeysOFF = keysOFF False | 230 | allKeysOFF = keysOFF False |
228 | allKeysReallyOFF = keysOFF True | 231 | allKeysReallyOFF = keysOFF True |
229 | 232 | ||
@@ -239,12 +242,12 @@ main = | |||
239 | -- let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown' | 242 | -- let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown' |
240 | -- textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord | 243 | -- textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord |
241 | 244 | ||
242 | smartDrawKeys False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size | 245 | smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size |
243 | return () | 246 | return () |
244 | 247 | ||
245 | Control.Monad.when (restartVideo) $ do | 248 | Control.Monad.when (restartVideo) $ do |
246 | allKeysOFF | 249 | allKeysOFF |
247 | smartDrawKeys False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size | 250 | smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size |
248 | return () | 251 | return () |
249 | 252 | ||
250 | Control.Monad.when (keysDown' /= keysDown) $ do | 253 | Control.Monad.when (keysDown' /= keysDown) $ do |
@@ -272,9 +275,9 @@ main = | |||
272 | let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds) | 275 | let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds) |
273 | SDL.delay (delay) | 276 | SDL.delay (delay) |
274 | Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $ | 277 | Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $ |
275 | loop (LoopState False) midiKeysDown' keysDown' resolution' font' s' w' x' | 278 | loop (LoopState False colsRepeat') midiKeysDown' keysDown' resolution' font' s' w' x' |
276 | 279 | ||
277 | loop (LoopState True) Set.empty Set.empty (sWidth, sHeight) font clockSession_ netwireIsCool "" | 280 | loop (LoopState True _AXIS_COLS_REPEAT) Set.empty Set.empty (sWidth, sHeight) font clockSession_ netwireIsCool "" |
278 | 281 | ||
279 | zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls) | 282 | zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls) |
280 | 283 | ||
@@ -297,14 +300,14 @@ centerText videoSurface x y font fgColor bgColor text = do | |||
297 | _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h)) | 300 | _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h)) |
298 | return () | 301 | return () |
299 | 302 | ||
300 | pitchIndex = concat $ map (\x -> unique) [0 .. _AXIS_COLS_REPEAT - 1] | 303 | pitchIndex colsRepeat = concat $ map (\x -> unique) [0 .. colsRepeat - 1] |
301 | where | 304 | where |
302 | 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] | 305 | 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] |
303 | colfrom top = map (+ top) $ map (* (-7)) [0 .. _AXIS_ROWS - 1] | 306 | colfrom top = map (+ top) $ map (* (-7)) [0 .. _AXIS_ROWS - 1] |
304 | unique = concat $ map colfrom toprow | 307 | unique = concat $ map colfrom toprow |
305 | 308 | ||
306 | getKeyLocations (SDL.Rect offx offy totalw totalh) = | 309 | getKeyLocations colsRepeat (SDL.Rect offx offy totalw totalh) = |
307 | let (key_height, key_width, xys) = getKeyLocationsAbs | 310 | let (key_height, key_width, xys) = getKeyLocationsAbs colsRepeat |
308 | 311 | ||
309 | screenw = fromIntegral(totalw) | 312 | screenw = fromIntegral(totalw) |
310 | screenh = fromIntegral(totalh) | 313 | screenh = fromIntegral(totalh) |
@@ -330,9 +333,9 @@ getKeyLocations (SDL.Rect offx offy totalw totalh) = | |||
330 | in | 333 | in |
331 | (floor(kw/2 * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw/2), floor(scale * y + centery + kh/2))) $ concat $ zipzip xys) | 334 | (floor(kw/2 * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw/2), floor(scale * y + centery + kh/2))) $ concat $ zipzip xys) |
332 | 335 | ||
333 | getKeyLocationsAbs = | 336 | getKeyLocationsAbs colsRepeat = |
334 | let kb_rows = (fromIntegral _AXIS_ROWS) :: Double | 337 | let kb_rows = (fromIntegral _AXIS_ROWS) :: Double |
335 | kb_cols = _AXIS_COLS_REPEAT * (fromIntegral _AXIS_UNIQUE_COLS) :: Double | 338 | kb_cols = (fromIntegral colsRepeat) * (fromIntegral _AXIS_UNIQUE_COLS) :: Double |
336 | -- the edges of the hexagon are equal in length to its "radius" | 339 | -- the edges of the hexagon are equal in length to its "radius" |
337 | -- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next | 340 | -- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next |
338 | -- or else it is 2*sqrt(3) to move down | 341 | -- or else it is 2*sqrt(3) to move down |