summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--axis.hs39
1 files changed, 21 insertions, 18 deletions
diff --git a/axis.hs b/axis.hs
index d9a3860..fe8a2e6 100644
--- a/axis.hs
+++ b/axis.hs
@@ -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
119smartDrawKeys :: (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 ()
120smartDrawKeys reallyErase beforeKeys_ nowKeys_ videoSurface font axis_key_locations axis_key_size = do 120smartDrawKeys 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
167chooseFontSize h w = 30 * d `div` 1024 where d = min h w 167chooseFontSize h w = 30 * d `div` 1024 where d = min h w
168 168
169data LoopState = LoopState { 169data LoopState = LoopState {
170 firstLoop :: Bool 170 firstLoop :: Bool,
171 repeatCols :: Integer
171} deriving (Show) 172} deriving (Show)
172 173
173main = 174main =
@@ -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
279zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls) 282zipzip 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
300pitchIndex = concat $ map (\x -> unique) [0 .. _AXIS_COLS_REPEAT - 1] 303pitchIndex 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
306getKeyLocations (SDL.Rect offx offy totalw totalh) = 309getKeyLocations 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
333getKeyLocationsAbs = 336getKeyLocationsAbs 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