color the keyboard axis-style

the borders on keys have been disabled

1 files changed, 32 insertions, 14 deletions

diff --git a/axis.hs b/axis.hs
index e35f7a8..9046eff 100644
--- a/axis.hs
+++ b/axis.hs
@@ -45,12 +45,14 @@ _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
 
-_KEY_COLOR = (SDL.Color 0 0 255)
-_KEY_BG_COLOR = (SDL.Color 0 0 0)
+--_KEY_BORDER_COLOR = (SDL.Color 0 0 255)
+_KEY_BORDER_COLOR = (SDL.Color 0 0 0)
+_KEY_ON_COLOR = (SDL.Color 0xAA 0x00 0xFF)
+_KB_BG_COLOR = (SDL.Color 0 0 0)
 _KEY_TEXT_COLOR = (SDL.Color 128 128 0)
 
-_KEY_COLOR_PIXEL = colorToPixel _KEY_COLOR
-_KEY_BG_COLOR_PIXEL = colorToPixel _KEY_BG_COLOR
+_KEY_BORDER_COLOR_PIXEL = colorToPixel _KEY_BORDER_COLOR
+_KB_BG_COLOR_PIXEL = colorToPixel _KB_BG_COLOR
 
 {-
 http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter
@@ -72,7 +74,7 @@ http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter
 15 – bright white               (#FFFFFF) 111111  63
 -}
 
-_CGA = [--(SDL.Color 0x00 0x00 0x00),        --black
+_CGA = [  (SDL.Color 0x00 0x00 0x00),        --black
           (SDL.Color 0x00 0x00 0xAA),        --blue
           (SDL.Color 0x00 0xAA 0x00),        --green
           (SDL.Color 0x00 0xAA 0xAA),        --cyan
@@ -89,6 +91,8 @@ _CGA = [--(SDL.Color 0x00 0x00 0x00),        --black
           (SDL.Color 0xFF 0xFF 0x55),        --bright yellow
           (SDL.Color 0xFF 0xFF 0xFF)]        --bright white
 
+_CHAN_TO_COLOR = _KEY_ON_COLOR : (tail _CGA)
+
 _drawHexircle f v x y s c =
   if _USE_HEXAGONS
   then _drawHexagonSDL f v x y s c
@@ -98,29 +102,43 @@ drawHexircle  = _drawHexircle False
 drawFilledHexircle = _drawHexircle True
 colorToPixel x = let (SDL.Color r g b) = x in rgbColor r g b
 
+inMajorC pclass = not (pclass == 1 || pclass == 3 || pclass == 6 || pclass == 8 || pclass == 10)
+
+-- TODO: color schemes with per-key {bg, border, hilightcolor, textcolor}
+-- 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
+
+pitchToColor p =
+  case p `mod` 12 of
+    2 -> (SDL.Color 0xD0 0xD0 0xFF) -- D
+    8 -> _CGA !! 1 -- G#
+    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
-  let eraseList = filter (\ (c, _) -> unChannel c /= 9) $ Set.toList eraseSet
+      eraseList = filter (\ (c, _) -> unChannel c /= 9) $ Set.toList eraseSet
 
   forM_ [(eraseList, True), (drawList, False)] $ \ (ls, erase) -> do
     forM_ ls $ \ (c, n) -> do
       let text = smartShowPitch (unPitch n)
-      let pitch = if _OCTAVE_SQUASH then (unPitch n) `mod` 12 + 12 * 6 else (unPitch n)
-      let chann = unChannel c
-      let fillColor = if _COLORIZE_BY_CHANNEL
-                      then _CGA !! (((fromIntegral chann) + 2) `mod` 16)
-                      else _KEY_COLOR
+          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
+          offColor = pitchToColor pitch
       forM_ (elemIndices pitch pitchIndex) $ \idx -> do
         drawKey idx videoSurface font axis_key_locations axis_key_size
-          (if erase then _KEY_BG_COLOR else fillColor) -- TODO: rename KEY_BG_COLOR as CANVAS_BG_COLOR
-          (if reallyErase then _KEY_BG_COLOR_PIXEL else _KEY_COLOR_PIXEL)
+          (if erase then (if reallyErase then _KB_BG_COLOR else offColor) else onColor)
+          (if reallyErase then _KB_BG_COLOR_PIXEL else _KEY_BORDER_COLOR_PIXEL)
           (if erase then Nothing else (Just text))
 
 drawKey idx videoSurface font axis_key_locations axis_key_size fillColor borderColor text = 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
+  --drawHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) borderColor
   case text of
     (Just t) -> centerText videoSurface x y font _KEY_TEXT_COLOR fillColor t
     _ -> return ()