add "octave squash" functionality but disable it

it looks terrible because the squashing is into a horizontal band.

2 files changed, 49 insertions, 52 deletions

diff --git a/AlsaSeq.hs b/AlsaSeq.hs
index 0d722e9..99e7c80 100644
--- a/AlsaSeq.hs
+++ b/AlsaSeq.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE NondecreasingIndentation #-}
-module AlsaSeq (withAlsaInit, parseAlsaEvents, forwardNoteEvent, cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch, unPitch, unChannel) 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
diff --git a/axis.hs b/axis.hs
index 312283e..e35f7a8 100644
--- a/axis.hs
+++ b/axis.hs
@@ -18,6 +18,7 @@ import qualified System.Exit as Exit
 import Data.List (elemIndex, elemIndices, filter)
 import GHC.Word
 import Data.Bits
+import qualified Sound.ALSA.Sequencer.Event as Event
 
 netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String
 netwireIsCool =
@@ -42,6 +43,7 @@ _AXIS_UNIQUE_COLS = 7
 _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
 
 _KEY_COLOR = (SDL.Color 0 0 255)
 _KEY_BG_COLOR = (SDL.Color 0 0 0)
@@ -70,22 +72,22 @@ http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter
 15 – bright white               (#FFFFFF) 111111  63
 -}
 
-_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                    
-          (SDL.Color 0xAA 0x00 0x00),        --red                     
-          (SDL.Color 0xAA 0x00 0xAA),        --magenta                 
-          (SDL.Color 0xAA 0x55 0x00),        --brown                   
-          (SDL.Color 0xAA 0xAA 0xAA),        --white / light gray      
+_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
+          (SDL.Color 0xAA 0x00 0x00),        --red
+          (SDL.Color 0xAA 0x00 0xAA),        --magenta
+          (SDL.Color 0xAA 0x55 0x00),        --brown
+          (SDL.Color 0xAA 0xAA 0xAA),        --white / light gray
           (SDL.Color 0x55 0x55 0x55),        --dark gray / bright black
-          (SDL.Color 0x55 0x55 0xFF),        --bright blue             
-          (SDL.Color 0x55 0xFF 0x55),        --bright green            
-          (SDL.Color 0x55 0xFF 0xFF),        --bright cyan             
-          (SDL.Color 0xFF 0x55 0x55),        --bright red              
-          (SDL.Color 0xFF 0x55 0xFF),        --bright magenta          
-          (SDL.Color 0xFF 0xFF 0x55),        --bright yellow           
-          (SDL.Color 0xFF 0xFF 0xFF)]        --bright white            
+          (SDL.Color 0x55 0x55 0xFF),        --bright blue
+          (SDL.Color 0x55 0xFF 0x55),        --bright green
+          (SDL.Color 0x55 0xFF 0xFF),        --bright cyan
+          (SDL.Color 0xFF 0x55 0x55),        --bright red
+          (SDL.Color 0xFF 0x55 0xFF),        --bright magenta
+          (SDL.Color 0xFF 0xFF 0x55),        --bright yellow
+          (SDL.Color 0xFF 0xFF 0xFF)]        --bright white
 
 _drawHexircle f v x y s c =
   if _USE_HEXAGONS
@@ -96,47 +98,40 @@ 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
+smartDrawKeys reallyErase drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do
 
-  forM_ pitches $ \pitch -> do
-    forM_ (elemIndices pitch pitchIndex) $ \idx -> do
-      let (x, y) = axis_key_locations !! idx
-      drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) _KEY_COLOR_PIXEL
-      centerText videoSurface x y font _KEY_TEXT_COLOR _KEY_COLOR (smartShowPitch pitch)
+  let drawList  = filter (\ (c, _) -> unChannel c /= 9) $ Set.toList drawSet
+  let 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
+      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 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
+  case text of
+    (Just t) -> centerText videoSurface x y font _KEY_TEXT_COLOR fillColor t
+    _ -> return ()
+
+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
 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) $ filter (\ (c, _) -> unChannel c /= 9) $ Set.toList eraseSet
-
-  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
-    forM_ (elemIndices pitch pitchIndex) $ \idx -> do
-      let (x, y) = axis_key_locations !! idx
-      drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) _KEY_BG_COLOR_PIXEL
-      drawHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (if really then _KEY_BG_COLOR_PIXEL else _KEY_COLOR_PIXEL)
---    centerText videoSurface x y font _KEY_TEXT_COLOR _KEY_BG_COLOR (smartShowPitch pitch)
-
 fi = fromIntegral
 rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. (fi 255))