From 84b5695349e4d549e2535003a6321f450862ac62 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Mon, 20 Jan 2014 11:02:51 -0500 Subject: correctly implement multi-channel display --- axis.hs | 78 ++++++++++++++++++++++++----------------------------------------- 1 file changed, 29 insertions(+), 49 deletions(-) (limited to 'axis.hs') diff --git a/axis.hs b/axis.hs index 768e4fa..e263862 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, groupBy, length, reverse) +import Data.List (elemIndex, elemIndices, filter, groupBy, length, reverse, sort) 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 = 1 +_AXIS_COLS_REPEAT = 2 _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 @@ -108,6 +108,7 @@ inMajorC pclass = not (pclass == 1 || pclass == 3 || pclass == 6 || pclass == 8 -- 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 +_UNLABELLED_KEYS = True pitchToColor p = case p `mod` 12 of 2 -> (SDL.Color 0xD0 0xD0 0xFF) -- D @@ -115,41 +116,32 @@ pitchToColor p = x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7 _ -> _CGA !! 8 -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 oldKeys nowKeys videoSurface font axis_key_locations axis_key_size = do +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 beforeKeys_ nowKeys_ videoSurface font axis_key_locations axis_key_size = do let - ignoreThese = Set.intersection nowKeys oldKeys - drawThese = Set.difference nowKeys ignoreThese - eraseThese = Set.difference oldKeys ignoreThese - drawSet = Set.difference nowKeys ignoreThese - eraseSet = Set.difference oldKeys ignoreThese - - 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 $ \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 - onColor = _KEY_ON_COLOR - offColor = pitchToColor pitch - forM_ (elemIndices pitch pitchIndex) $ \idx -> do - 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 :: (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 + 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 = if _OCTAVE_SQUASH then unPitch n `mod` 12 + 12 * 6 else unPitch n + forM_ (elemIndices pitch pitchIndex) $ \idx -> do + drawKey idx videoSurface font axis_key_locations axis_key_size + (if reallyErase then _KB_BG_COLOR else pitchToColor pitch) + (if reallyErase || _UNLABELLED_KEYS then Nothing else (Just text)) + chans + +--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) @@ -160,8 +152,8 @@ drawKey idx videoSurface font axis_key_locations axis_key_size fillColor borderC 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 + chan = channels' !! i + color = _CHAN_TO_COLOR !! fromIntegral(unChannel chan) SDL.Primitive.filledCircle videoSurface x'' y'' (round r') (colorToPixel color) case text of @@ -200,7 +192,7 @@ main = let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOM_PITCH .. _AXIS_TOP_PITCH] - keysOFF really = smartDrawKeys' really _ALL_PITCHES Set.empty videoSurface font axis_key_locations axis_key_size + keysOFF really = smartDrawKeys really _ALL_PITCHES Set.empty videoSurface font axis_key_locations axis_key_size allKeysOFF = keysOFF False allKeysReallyOFF = keysOFF True allKeysOFF @@ -225,19 +217,7 @@ main = -- let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown' -- textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord - -- gah! This is all wrong with the channels added! Unless - -- smartDrawKeys gets smarter... but really, this interface - -- is awkward now and should be changed. - -- - -- What we actually want here is the set of pitches where - -- there has been an event. Which is simply derived from - -- just the Set.difference midiKeys midiKeys'. But we also - -- want the set of channels for each pitch -- which is just - -- midiKeysDown' (processed as we are doing already in - -- smartDrawKeys). Then we build up a map of pitches -> - -- channels. - - smartDrawKeys' False midiKeysDown midiKeysDown' videoSurface font axis_key_locations axis_key_size + smartDrawKeys False midiKeysDown midiKeysDown' videoSurface font axis_key_locations axis_key_size return () Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF -- cgit v1.2.3