correctly implement multi-channel display

1 files changed, 29 insertions, 49 deletions

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