live playback works! connect via aplaymidi to play midi files

1 files changed, 67 insertions, 25 deletions

diff --git a/axis.hs b/axis.hs
index 3108779..bfbe169 100644
--- a/axis.hs
+++ b/axis.hs
@@ -16,6 +16,8 @@ import Graphics.UI.SDL.Primitives as SDL.Primitive
 import Data.Int (Int16)
 import qualified System.Exit as Exit
 import Data.List (elemIndex, elemIndices)
+import GHC.Word
+import Data.Bits
 
 netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String
 netwireIsCool =
@@ -30,6 +32,44 @@ netwireIsCool =
         holdFor 0.5 . periodic 1 . pure "Hoo..." <|>
         pure "...ray!"
 
+smartShowPitch p = showPitch p -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars
+
+_USE_HEXAGONS = True
+
+_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` 8) c
+
+drawHexircle  = _drawHexircle False
+drawFilledHexircle = _drawHexircle True
+
+_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)
+
+drawKeys 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_COLOR_PIXEL
+      centerText videoSurface x y font _KEY_TEXT_COLOR _KEY_COLOR (smartShowPitch pitch)
+
+eraseKeys 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) _KEY_COLOR_PIXEL
+
+fi = fromIntegral
+rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. (fi 255))
+
 main =
   withAlsaInit $ \h public private q publicAddr privateAddr -> do
   cmdlineAlsaConnect h public -- fail early if bad command lines
@@ -51,20 +91,15 @@ main =
   _ <- SDL.grabInput True
   warpMouse
 
-  let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
-  blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue???
+--let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
+  pixelFormat <- SDL.surfaceGetPixelFormat <$> SDL.createRGBSurfaceEndian [] 1 1 24
   -- _ <- SDL.setRelativeMouseMode True -- SDL2.  Should I use it?
 
   let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect
 
-  forM_ axis_key_locations $ \(x, y) -> do
-    --SDL.Primitive.filledCircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return
-    drawHexagonSDL videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return
-
-  forM_ [0 .. length axis_key_locations - 1] $ \i -> do
-    let (centerx, centery) = axis_key_locations !! i
-    centerText videoSurface centerx centery font (showPitch $ pitchIndex !! i)
---  centerText videoSurface centerx centery font (show i)
+  let allPitches = map (+ 35) [0 .. 49]
+--drawKeys allPitches videoSurface font blue axis_key_locations axis_key_size
+  eraseKeys allPitches videoSurface font axis_key_locations axis_key_size
 
   putStrLn "Initialized."
 
@@ -77,22 +112,28 @@ main =
         let x' = either (const "") id ex
 
         Control.Monad.when (x /= x' && x' /= "") $ do
-          textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x'
+--        textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x'
           return ()
 
         Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do
           --let chord = showChord midiKeysDown'
           --let chord = show $ pitchList midiKeysDown'
+          let ignoreThese = Set.intersection midiKeysDown' midiKeysDown
+          let drawThese = pitchList $ Set.difference midiKeysDown' ignoreThese
+          let eraseThese = pitchList $ Set.difference midiKeysDown ignoreThese
+
           let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown'
-          textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
+          drawKeys  drawThese  videoSurface font axis_key_locations axis_key_size
+          eraseKeys eraseThese videoSurface font axis_key_locations axis_key_size
+--        textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
           return ()
 
-        Control.Monad.when (keysDown' /= keysDown) $ do
-          let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown'
-          textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord
-          textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $
-            if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else ""
-          return ()
+--      Control.Monad.when (keysDown' /= keysDown) $ do
+--        let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown'
+--        textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord
+--        textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $
+--          if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else ""
+--        return ()
 
         Control.Monad.when(False) $ do
 
@@ -114,24 +155,25 @@ main =
 
 zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls)
 
-drawHexagonSDL videoSurface centerx centery radius pixel = do
+drawHexagonSDL = _drawHexagonSDL False
+drawFilledHexagonSDL = _drawHexagonSDL True
+
+_drawHexagonSDL filled videoSurface centerx centery radius pixel = do
   let r = fromIntegral radius
---let points = map (\(x, y) -> (centerx + x + radius `div` 2, centery + y + radius `div` 2)) $
   let points = map (\(x, y) -> (centerx + x, centery + y)) $
                map (\(x, y) -> (round x, round y)) $
                map (\i -> (r * cos(pi/3 * (i)), r * sin(pi/3 * (i)))) $ map fromIntegral [0 .. 5]
-  --filledPolygon :: Surface -> [(Int16, Int16)] -> Pixel -> IO Bool
-  SDL.Primitive.polygon videoSurface points pixel >>= return
-  return ()
+  (if not filled then SDL.Primitive.polygon else SDL.Primitive.filledPolygon) videoSurface points pixel
 
-centerText videoSurface x y font text = 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 (SDL.Color 0 255 0) (SDL.Color 0 0 0)
+  fontSurface <- SDL.TTF.renderUTF8Shaded font text fgColor bgColor
   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))
   return ()
 
+-- TODO: make this generalize to different grid sizes
 colfrom top = map (+ top) $ map (* (-7)) [0 .. 6]
 pitchIndex = (\x -> x ++ x) $ concat $ map colfrom [81, 78, 82, 79, 83, 80, 84]