keys have different colors depending on channel

this is disabled by a constant, but it does work

2 files changed, 55 insertions, 18 deletions

diff --git a/AlsaSeq.hs b/AlsaSeq.hs
index a3905c8..0d722e9 100644
--- a/AlsaSeq.hs
+++ b/AlsaSeq.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE NondecreasingIndentation #-}
-module AlsaSeq (withAlsaInit, parseAlsaEvents, forwardNoteEvent, cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch, unPitch) where
+module AlsaSeq (withAlsaInit, parseAlsaEvents, forwardNoteEvent, cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch, unPitch, unChannel) where
 import qualified Sound.ALSA.Exception as AlsaExc
 import qualified Sound.ALSA.Sequencer.Address as Addr
 import qualified Sound.ALSA.Sequencer as SndSeq
@@ -27,6 +27,7 @@ import Foreign.C.Error (Errno(Errno))
 import Control.Exception.Base (try)
 
 unPitch = Event.unPitch
+unChannel = Event.unChannel
 
 printChordLn set = printWords $ pitchWords set
 
@@ -42,10 +43,9 @@ showPitch x =
   let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x
   in Haskore.Basic.Pitch.classFormat pitch (show octave)
 
--- TODO: don't filter percussion here.
 pitchWords set = map showPitch $ pitchList set
-pitchList set = map Event.unPitch $ map (\ (c, n) -> n) $ filter (\ (Event.Channel c, n) -> c /= 20) $ Set.toList set
-pitchLists set = map (\ (c, n) -> (Event.unChannel c, Event.unPitch n)) $ filter (\ (Event.Channel c, n) -> c /= 20) $ Set.toList set
+pitchList set = map Event.unPitch $ map (\ (c, n) -> n) $ Set.toList set
+pitchLists set = map (\ (c, n) -> (Event.unChannel c, Event.unPitch n)) $ Set.toList set
 
 prettyNote :: Event.Note -> String
 prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) =
diff --git a/axis.hs b/axis.hs
index c14c0a7..a51b846 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)
+import Data.List (elemIndex, elemIndices, filter)
 import GHC.Word
 import Data.Bits
 
@@ -35,18 +35,11 @@ netwireIsCool =
 smartShowPitch p = showPitch p -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars
 
 _USE_HEXAGONS = False
-
-_drawHexircle f v x y s c =
-  if _USE_HEXAGONS
-  then _drawHexagonSDL f v x y s c
-  else (if f then SDL.Primitive.filledCircle else SDL.Primitive.circle) v x y (s * 7 `div` 9) c
-
-drawHexircle  = _drawHexircle False
-drawFilledHexircle = _drawHexircle True
+_COLORIZE_BY_CHANNEL = False
 
 _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
 
@@ -54,8 +47,39 @@ _KEY_COLOR = (SDL.Color 0 0 255)
 _KEY_BG_COLOR = (SDL.Color 0 0 0)
 _KEY_TEXT_COLOR = (SDL.Color 128 128 0)
 
-_KEY_COLOR_PIXEL = let (SDL.Color r g b) = _KEY_COLOR in (rgbColor r g b)
-_KEY_BG_COLOR_PIXEL = let (SDL.Color r g b) = _KEY_BG_COLOR in (rgbColor r g b)
+_KEY_COLOR_PIXEL = colorToPixel _KEY_COLOR
+_KEY_BG_COLOR_PIXEL = colorToPixel _KEY_BG_COLOR
+
+{-
+http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter
+ 0 – black                      (#000000) 000000  0
+ 1 – blue                       (#0000AA) 000001  1
+ 2 – green                      (#00AA00) 000010  2
+ 3 – cyan                       (#00AAAA) 000011  3
+ 4 – red                        (#AA0000) 000100  4
+ 5 – magenta                    (#AA00AA) 000101  5
+ 6 – brown                      (#AA5500) 010100  20
+ 7 – white / light gray         (#AAAAAA) 000111  7
+ 8 – dark gray / bright black   (#555555) 111000  56
+ 9 – bright blue                (#5555FF) 111001  57
+10 – bright green               (#55FF55) 111010  58
+11 – bright cyan                (#55FFFF) 111011  59
+12 – bright red                 (#FF5555) 111100  60
+13 – bright magenta             (#FF55FF) 111101  61
+14 – bright yellow              (#FFFF55) 111110  62
+15 – bright white               (#FFFFFF) 111111  63
+-}
+
+_CGA = [(SDL.Color 0x00 0x00 0x00), (SDL.Color 0x00 0x00 0xAA), (SDL.Color 0x00 0xAA 0x00), (SDL.Color 0x00 0xAA 0xAA), (SDL.Color 0xAA 0x00 0x00), (SDL.Color 0xAA 0x00 0xAA), (SDL.Color 0xAA 0x55 0x00), (SDL.Color 0xAA 0xAA 0xAA), (SDL.Color 0x55 0x55 0x55), (SDL.Color 0x55 0x55 0xFF), (SDL.Color 0x55 0xFF 0x55), (SDL.Color 0x55 0xFF 0xFF), (SDL.Color 0xFF 0x55 0x55), (SDL.Color 0xFF 0x55 0xFF), (SDL.Color 0xFF 0xFF 0x55), (SDL.Color 0xFF 0xFF 0xFF)]
+
+_drawHexircle f v x y s c =
+  if _USE_HEXAGONS
+  then _drawHexagonSDL f v x y s c
+  else (if f then SDL.Primitive.filledCircle else SDL.Primitive.circle) v x y (s * 7 `div` 9) c
+
+drawHexircle  = _drawHexircle False
+drawFilledHexircle = _drawHexircle True
+colorToPixel x = let (SDL.Color r g b) = x in rgbColor r g b
 
 drawKeys pitches videoSurface font axis_key_locations axis_key_size = do
 
@@ -68,14 +92,27 @@ drawKeys pitches videoSurface font axis_key_locations axis_key_size = do
 reallyEraseKeys = eraseKeys_ True
 eraseKeys = eraseKeys_ False
 
+
 smartDrawKeys really drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do
 
   let drawList  = map (\ (_, n) -> unPitch n) $ Set.toList drawSet
-  let eraseList = map (\ (_, n) -> unPitch n) $ Set.toList eraseSet
+  let eraseList = map (\ (_, n) -> unPitch n) $ filter (\ (c, _) -> unChannel c /= 9) $ Set.toList eraseSet
 
-  drawKeys           drawList videoSurface font axis_key_locations axis_key_size
   eraseKeys_ really eraseList videoSurface font axis_key_locations axis_key_size
 
+  forM_ (Set.toList drawSet) $ \ (c, n) -> do
+    let pitch = unPitch n
+    let chann = unChannel c
+    let color = if _COLORIZE_BY_CHANNEL
+                then _CGA !! (((fromIntegral chann) + 2) `mod` 16)
+                else _KEY_COLOR
+    Control.Monad.when(chann /= 9) $ -- TODO: do this elsewhere
+      forM_ (elemIndices pitch pitchIndex) $ \idx -> do
+        let (x, y) = axis_key_locations !! idx
+        drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel color)
+        drawHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) _KEY_COLOR_PIXEL
+        centerText videoSurface x y font _KEY_TEXT_COLOR color (smartShowPitch pitch)
+
 eraseKeys_ really pitches videoSurface font axis_key_locations axis_key_size = do
 
   forM_ pitches $ \pitch -> do