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.

1 files 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))