From e2c1145e5f52c7c57feb8831275732b095b36e02 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sun, 19 Jan 2014 15:27:42 -0500 Subject: displaying multiple channels on one key simultaneously it does not look great (yet), but it makes the multi-channel midi files much less confusing to watch. --- axis.hs | 55 ++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 36 insertions(+), 19 deletions(-) diff --git a/axis.hs b/axis.hs index 9046eff..e6720ad 100644 --- a/axis.hs +++ b/axis.hs @@ -15,7 +15,7 @@ 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) +import Data.List (elemIndex, elemIndices, filter, groupBy, length, reverse) import GHC.Word import Data.Bits import qualified Sound.ALSA.Sequencer.Event as Event @@ -40,7 +40,7 @@ _COLORIZE_BY_CHANNEL = True _AXIS_ROWS = 7 + 4 _AXIS_UNIQUE_COLS = 7 -_AXIS_COLS_REPEAT = 2 +_AXIS_COLS_REPEAT = 1 _AXIS_TOP_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2) _AXIS_BOTTOM_PITCH = 81 - (7 * _AXIS_ROWS) - 3 _OCTAVE_SQUASH = False -- it's terrible, because it draws the octave in the wrong shape @@ -115,30 +115,46 @@ pitchToColor p = x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7 _ -> _CGA !! 8 -smartDrawKeys reallyErase drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do - - let drawList = filter (\ (c, _) -> unChannel c /= 9) $ Set.toList drawSet - eraseList = filter (\ (c, _) -> unChannel c /= 9) $ Set.toList eraseSet +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 () +smartDrawKeys' reallyErase drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do + let + changroup = groupBy (\(_, n1) (_, n2) -> n1 == n2) + chanfilter = filter (\ (c, _) -> unChannel c /= 9) + drawList = changroup . chanfilter $ Set.toList drawSet + eraseList = changroup . chanfilter $ Set.toList eraseSet forM_ [(eraseList, True), (drawList, False)] $ \ (ls, erase) -> do - forM_ ls $ \ (c, n) -> do - let text = smartShowPitch (unPitch n) + forM_ ls $ \ls' -> do + let chans = map (\ (c, _) -> unChannel c) ls' + (_, n) = head ls' + text = smartShowPitch (unPitch n) pitch = if _OCTAVE_SQUASH then (unPitch n) `mod` 12 + 12 * 6 else (unPitch n) - chann = unChannel c - onColor = if _COLORIZE_BY_CHANNEL - then _CHAN_TO_COLOR !! ((fromIntegral chann) `mod` 16) - else _KEY_ON_COLOR + onColor = _KEY_ON_COLOR offColor = pitchToColor pitch forM_ (elemIndices pitch pitchIndex) $ \idx -> do - drawKey idx videoSurface font axis_key_locations axis_key_size - (if erase then (if reallyErase then _KB_BG_COLOR else offColor) else onColor) + drawKey' idx videoSurface font axis_key_locations axis_key_size + offColor (if reallyErase then _KB_BG_COLOR_PIXEL else _KEY_BORDER_COLOR_PIXEL) (if erase then Nothing else (Just text)) + (if erase then [] else (map fromIntegral chans)) -drawKey idx videoSurface font axis_key_locations axis_key_size fillColor borderColor text = do +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 borderColor text channels = do let (x, y) = axis_key_locations !! idx drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor) - --drawHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) borderColor + let len = length 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(pi/3 * fromIntegral(i)), d * sin(pi/3 * fromIntegral(i))) + 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 !! 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 () @@ -146,7 +162,7 @@ drawKey idx videoSurface font axis_key_locations axis_key_size fillColor borderC eraseKeys_ really pitches videoSurface font axis_key_locations axis_key_size = let pitchSet = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) pitches in - smartDrawKeys really Set.empty pitchSet videoSurface font axis_key_locations axis_key_size + smartDrawKeys' really Set.empty pitchSet videoSurface font axis_key_locations axis_key_size reallyEraseKeys = eraseKeys_ True eraseKeys = eraseKeys_ False @@ -209,7 +225,7 @@ main = let drawThese = Set.difference midiKeysDown' ignoreThese let eraseThese = Set.difference midiKeysDown ignoreThese - smartDrawKeys False drawThese eraseThese videoSurface font axis_key_locations axis_key_size + smartDrawKeys' False drawThese eraseThese videoSurface font axis_key_locations axis_key_size return () Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF @@ -254,7 +270,8 @@ _drawHexagonSDL filled videoSurface centerx centery radius pixel = do 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.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)) -- cgit v1.2.3