From 4d4f7d74c370040ee102367d1c06953aa33896b9 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Fri, 17 Jan 2014 05:42:53 -0500 Subject: live playback works! connect via aplaymidi to play midi files --- axis.hs | 92 +++++++++++++++++++++++++++++++++++++++++++++++------------------ 1 file 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] -- cgit v1.2.3