{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} import Prelude () import BasePrelude -- import Data.Time.Clock import Control.Monad import qualified Graphics.UI.SDL as SDL import AlsaSeq import qualified Data.Set as Set import qualified Graphics.UI.SDL.TTF as SDL.TTF import Graphics.UI.SDL.Keysym as SDL.Keysym import Graphics.UI.SDL.Primitives as SDL.Primitive import qualified Sound.ALSA.Sequencer.Event as Event import qualified Graphics.UI.SDL.Utilities as SDL.Util import qualified Data.Map as Map import Control.Monad.RWS.Strict import qualified Sound.ALSA.Sequencer import qualified Sound.ALSA.Sequencer.Queue import qualified Sound.ALSA.Sequencer.Address import AlsaShutUp smartShowPitch :: Word8 -> String smartShowPitch = showPitch -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars _USE_HEXAGONS, _LABEL_WHILE_PLAYING, _LABEL_ALL_KEYS :: Bool _USE_HEXAGONS = True _LABEL_WHILE_PLAYING = True _LABEL_ALL_KEYS = False _AXIS_ROWS, _AXIS_UNIQUE_COLS, _AXIS_TOPLEFT_PITCH, _AXIS_BOTTOMLEFT_PITCH, _AXIS_TOPRIGHT_PITCH :: Word8 _AXIS_ROWS = 7 + 4 _AXIS_UNIQUE_COLS = 7 _AXIS_COLS_REPEAT :: Integer _AXIS_COLS_REPEAT = 2 _AXIS_TOPLEFT_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2) _AXIS_BOTTOMLEFT_PITCH = _AXIS_TOPLEFT_PITCH - (_AXIS_ROWS * 7) _AXIS_TOPRIGHT_PITCH = _AXIS_TOPLEFT_PITCH + _AXIS_UNIQUE_COLS `div` 2 _KEY_BORDER_COLOR, _KEY_ON_COLOR, _KB_BG_COLOR, _KEY_TEXT_COLOR :: SDL.Color --_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_BORDER_COLOR_PIXEL, _KB_BG_COLOR_PIXEL :: SDL.Pixel _KEY_BORDER_COLOR_PIXEL = colorToPixel _KEY_BORDER_COLOR _KB_BG_COLOR_PIXEL = colorToPixel _KB_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] _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 _CHAN_TO_COLOR :: [SDL.Color] _CHAN_TO_COLOR = _KEY_ON_COLOR : tail _CGA _drawHexircle :: Bool -> SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool _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 :: SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool drawHexircle = _drawHexircle False drawFilledHexircle :: SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool drawFilledHexircle = _drawHexircle True colorToPixel :: SDL.Color -> SDL.Pixel colorToPixel x = let (SDL.Color r g b) = x in rgbColor r g b inMajorC :: (Eq a, Num a) => a -> Bool 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 :: Integral a => a -> SDL.Color pitchToColor p = case p `mod` 12 of 2 -> SDL.Color 0xC0 0xC0 0xFF -- D 8 -> SDL.Color 0x33 0x33 0x66 -- G# x | inMajorC x -> SDL.Color 0xE0 0xE0 0xE0 -- _CGA !! 7 _ -> _CGA !! 8 smartDrawKeys :: (Enum a, Integral a1, Integral a3, Integral a2, Num a) => a -> Bool -> Set.Set (Event.Channel, Event.Pitch) -> Set.Set (Event.Channel, Event.Pitch) -> SDL.Surface -> SDL.TTF.Font -> [(a2, a3)] -> a1 -> IO () smartDrawKeys colsRepeat reallyErase beforeKeys_ nowKeys_ videoSurface font axis_key_locations axis_key_size = do let chanfilter = Set.filter (\ (c, _) -> c /= Event.Channel 9) beforeKeys = chanfilter beforeKeys_ nowKeys = chanfilter nowKeys_ changedPitches = Set.map snd $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys) playingNowChans n = Set.map fst $ Set.filter (\ (_, p) -> p == n) nowKeys actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches forM_ actions $ \ (n, chans) -> do let text = smartShowPitch (unPitch n) pitch = unPitch n indices = elemIndices pitch $ pitchIndex colsRepeat off = null chans forM_ indices $ \idx -> do let showLabel = not reallyErase && (_LABEL_ALL_KEYS || (_LABEL_WHILE_PLAYING && not off)) drawKey idx videoSurface font axis_key_locations axis_key_size (if reallyErase then _KB_BG_COLOR else pitchToColor pitch) (if showLabel then Just text else Nothing) chans allKeysOff :: (Enum b, Integral a, Integral a1, Integral a2, Num b) => b -> Bool -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> IO () allKeysOff colsRepeat reallyErase videoSurface font axis_key_locations axis_key_size = do let indices = [0 .. length axis_key_locations - 1] showLabel = not reallyErase && _LABEL_ALL_KEYS forM_ indices $ \idx -> do let pitch = pitchIndex colsRepeat !! idx bgColor = if reallyErase then _KB_BG_COLOR else pitchToColor pitch text = smartShowPitch pitch label = if showLabel then Just text else Nothing drawKey idx videoSurface font axis_key_locations axis_key_size bgColor label [] -- OK, what we need to do now... -- 1. change smartDrawKeys to take key locations instead of midi events; these are channel/location pairs -- 2. change the main loop to calculate the key locations, per channel, by choosing the location closest to the average from the last N locations -- That should be accomplished through a Data.Map mapping from each channel to a Data.Queue of locations -- Note that this data needs to be thrown out if the size of the keyboard changes. -- The data should also be thrown out if it gets too old; if the channel isn't being used -- The algorithm to choose can be stupid (just use the average), because -- the goal is just to get the code organized so that it has the -- previous locations available to make a choice. But a smart algorithm -- would choose based on the "structure" of the actual music. -- Question: how to deal with simultaneous keypresses? -- Next order of business: drawKey :: (Integral a, Integral a1, Integral a2) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> Maybe String -> [Event.Channel] -> IO () drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text channels = do let (x, y) = axis_key_locations !! idx void $ drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor) let len = length channels let channels' = sort channels Control.Monad.when (len /= 0) $ forM_ [0 .. len - 1] $ \i -> do let (x', y') = if len == 1 then (0, 0) else (d * cos(2*pi/lenf * ifi), d * sin(2*pi/lenf * ifi)) ifi = fromIntegral i lenf = fromIntegral len d = fromIntegral axis_key_size / 4 :: Float r' = fromIntegral axis_key_size / 2 :: Float x'' = round x' + fromIntegral x y'' = round y' + fromIntegral y chan = channels' !! i color = _CHAN_TO_COLOR !! fromIntegral(unChannel chan) SDL.Primitive.filledCircle videoSurface x'' y'' (round r') (colorToPixel color) case text of (Just t) -> centerText videoSurface x y font _KEY_TEXT_COLOR fillColor t _ -> return () rgbColor :: Word8 -> Word8 -> Word8 -> SDL.Pixel rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. fi 255) where fi = fromIntegral fi :: Word8 -> Word32 chooseFontSize :: Integral a => a -> a -> a chooseFontSize h w = 30 * d `div` 1024 where d = min h w _SDL_DIGITS :: Set.Set SDLKey _SDL_DIGITS = Set.fromList [SDL.SDLK_1, SDL.SDLK_2, SDL.SDLK_3, SDL.SDLK_4, SDL.SDLK_5, SDL.SDLK_6, SDL.SDLK_7, SDL.SDLK_8, SDL.SDLK_9, SDL.SDLK_0] firstDigitDown :: Set.Set SDL.Keysym.SDLKey -> Maybe Integer firstDigitDown k = if Set.null digitsDown then Nothing else Just $ (-48 +) $ fromIntegral $ SDL.Util.fromEnum $ Set.findMin digitsDown where digitsDown = Set.intersection _SDL_DIGITS k data LoopState = LoopState { _firstLoop :: Bool, _repeatCols :: Integer, _midiKeysDown :: Set.Set (Event.Channel, Event.Pitch), _sdlKeysDown :: Set.Set SDLKey, _sdlResolution :: (Int, Int), _sdlFont :: SDL.TTF.Font } data Env = Env { _h :: Sound.ALSA.Sequencer.T Sound.ALSA.Sequencer.DuplexMode, _q :: Sound.ALSA.Sequencer.Queue.T, _publicAddr :: Sound.ALSA.Sequencer.Address.T, _setVideoMode :: Int -> Int -> IO SDL.Surface, _warpMouse :: IO () } fontFile :: FilePath fontFile = "/usr/share/fonts/truetype/liberation/LiberationMono-Bold.ttf" main :: IO () main = withAlsaInit $ \h public private q publicAddr privateAddr -> do cmdlineAlsaConnect h public -- fail early if bad command lines SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ do info <- SDL.getVideoInfo let sWidth = SDL.videoInfoWidth info sHeight = SDL.videoInfoHeight info warpMouse = void $ SDL.warpMouse (fromIntegral (sWidth `div` 2)) (fromIntegral (sHeight `div` 2)) setVideoMode wid hei = SDL.setVideoMode wid hei 32 [SDL.HWSurface, SDL.Resizable, SDL.DoubleBuf] _ <- setVideoMode sWidth sHeight _ <- SDL.TTF.init font <- SDL.TTF.openFont fontFile (chooseFontSize sWidth sHeight) -- _ <- SDL.showCursor False _ <- SDL.grabInput True warpMouse _ <- SDL.setRelativeMouseMode True -- -- SDL2. Should I use it? using the pixelFormat methods gives the wrong color, with both the real -- pixelFormat or the faked one, so fuck it. See colorToPixel let pixelFormat = -- SDL.surfaceGetPixelFormat videoSurface pixelFormat <- SDL.surfaceGetPixelFormat <$> -- SDL.createRGBSurfaceEndian [] 1 1 24 void shutUp putStrLn "Initialized." (_, ()) <- execRWST mainLoop (Env h q publicAddr setVideoMode warpMouse) (LoopState True _AXIS_COLS_REPEAT Set.empty Set.empty (sWidth, sHeight) font) return () setFont :: (MonadIO m, MonadState LoopState m) => (Int, Int) -> m () setFont resolution = do let (w, h) = resolution fontSize = chooseFontSize w h font' <- liftIO $ SDL.TTF.openFont fontFile fontSize modify $ \s -> s { _sdlFont = font' } parseEvents :: RWST Env () LoopState IO (Bool, Set.Set SDLKey, MidiPitchSet, (Int, Int), Integer) parseEvents = do Env h q publicAddr setVideoMode _ <- ask LoopState _ colsRepeat midiKeysDown keysDown resolution _ <- get (keysDown', resolution') <- liftIO $ parseSDLEvents keysDown resolution midiKeysDown' <- liftIO $ parseAlsaEvents h midiKeysDown (forwardNoteEvent h q publicAddr) let colsRepeat' = case firstDigitDown keysDown' of Nothing -> colsRepeat (Just 0) -> colsRepeat (Just n) -> n let restartVideo = resolution' /= resolution || colsRepeat' /= colsRepeat return (restartVideo, keysDown', midiKeysDown', resolution', colsRepeat') mainLoop :: RWST Env () LoopState IO () mainLoop = do Env h q publicAddr setVideoMode _ <- ask LoopState firstLoop _ midiKeysDown keysDown _ _ <- get (restartVideo, keysDown', midiKeysDown', resolution, colsRepeat) <- parseEvents when restartVideo $ do let (wid, hei) = resolution void $ liftIO $ setVideoMode wid hei setFont resolution font <- gets _sdlFont videoSurface <- liftIO SDL.getVideoSurface videoClipRect <- liftIO $ SDL.getClipRect videoSurface let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat videoClipRect let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOMLEFT_PITCH .. _AXIS_TOPRIGHT_PITCH] keysOFF really = allKeysOff colsRepeat really videoSurface font axis_key_locations axis_key_size allKeysOFF = keysOFF False allKeysReallyOFF = keysOFF True when firstLoop $ liftIO allKeysOFF let chanfilter = Set.filter (\(c, _) -> c /= Event.Channel 9) beforeKeys = chanfilter midiKeysDown nowKeys = chanfilter midiKeysDown' changedPitches = Set.map snd $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys) playingNowChans n = Set.map fst $ Set.filter (\(_, p) -> p == n) nowKeys actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches chanPitches = Map.fromListWith (++) $ map (\(c, p) -> (c, [p])) $ Set.toList nowKeys when (midiKeysDown' /= midiKeysDown) $ do when False $ do let chord = showChord midiKeysDown' let chord = show $ pitchList midiKeysDown' let chord = show $ map (`elemIndices` pitchIndex colsRepeat) $ pitchList midiKeysDown' liftIO $ textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord liftIO $ smartDrawKeys colsRepeat False midiKeysDown midiKeysDown' videoSurface font axis_key_locations axis_key_size when restartVideo $ do liftIO allKeysOFF liftIO $ smartDrawKeys colsRepeat False Set.empty midiKeysDown' videoSurface font axis_key_locations axis_key_size when (keysDown' /= keysDown) $ do when (keyDown SDL.SDLK_BACKSPACE keysDown') $ liftIO allKeysOFF when (keyDown SDL.SDLK_c keysDown') $ liftIO allKeysReallyOFF when False $ mouseWarpTest videoSurface videoClipRect void $ liftIO $ SDL.flip videoSurface let framerate = 30 let delay = 1000 `div` framerate -- TODO: subtract delta liftIO $ SDL.delay delay unless (keyDown SDL.SDLK_ESCAPE keysDown) $ do put (LoopState False colsRepeat midiKeysDown' keysDown' resolution font) mainLoop mouseWarpTest videoSurface videoClipRect = do warpMouse <- asks _warpMouse font <- gets _sdlFont mouse <- liftIO SDL.getRelativeMouseState let (x, y, button) = mouse let text = unwords [show x, show y, show button] liftIO $ textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font text when (x /= 0 || y /= 0) $ liftIO warpMouse zipzip :: [[b]] -> [[b]] zipzip ls = if null (head ls) then [] else map head ls : zipzip (map tail ls) drawHexagonSDL, drawFilledHexagonSDL :: SDL.Surface -> Int16 -> Int16 -> Integer -> SDL.Pixel -> IO Bool drawHexagonSDL = _drawHexagonSDL False drawFilledHexagonSDL = _drawHexagonSDL True _drawHexagonSDL :: Integral a => Bool -> SDL.Surface -> Int16 -> Int16 -> a -> SDL.Pixel -> IO Bool _drawHexagonSDL filled videoSurface centerx centery radius pixel = do let r = fromIntegral radius let points = map ((((+) centerx *** (+) centery) . (round *** round)) . (\i -> (r * cos(pi/3 * i), r * sin(pi/3 * i)))) [0 .. 5] (if not filled then SDL.Primitive.polygon else SDL.Primitive.filledPolygon) videoSurface points pixel centerText :: (Integral a, Integral a1) => SDL.Surface -> a -> a1 -> SDL.TTF.Font -> SDL.Color -> t -> String -> IO () 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 fgColor bgColor fontSurface <- SDL.TTF.renderUTF8Blended font text fgColor 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 () pitchIndex :: (Enum b, Num b) => b -> [Word8] pitchIndex colsRepeat = concatMap (const unique) [0 .. colsRepeat - 1] where toprow = map (\i -> if i `mod` 2 == 0 then _AXIS_TOPLEFT_PITCH + i `div` 2 else _AXIS_TOPLEFT_PITCH - 3 + i `div` 2) [0 .. _AXIS_UNIQUE_COLS - 1] colfrom top = map ((+ top) . (* (-7))) [0 .. _AXIS_ROWS - 1] unique = concatMap colfrom toprow getKeyLocations :: (Integral a, Integral t, Integral t1, Integral t2) => a -> SDL.Rect -> (t, [(t1, t2)]) getKeyLocations colsRepeat (SDL.Rect offx offy totalw totalh) = let (key_height, key_width, xys) = getKeyLocationsAbs colsRepeat screenw = fromIntegral totalw screenh = fromIntegral totalh kb_rows = length xys kb_cols = length (head xys) -- there are 14 keys (13 steps) from the far left to the far right of the axis; if the radius is 1 each step is 1.5 horizontal, plus 2 halfs to fill to the edges -- thus the keyboard is radius * ((numkeys - 1) * 1.5 + 2) keyboard_width = (fromIntegral(kb_cols - 1) * 1.5 + 2) * key_width / 2 keyboard_height = fromIntegral(kb_rows + 1) * key_height -- half of the keyboard is offset down one key fit_width = screenh / screenw > keyboard_height / keyboard_width scale = if fit_width then screenw / keyboard_width else screenh / keyboard_height kh = key_height * scale kw = key_width * scale centerx = (screenw - keyboard_width * scale) / 2 centery = (screenh - keyboard_height * scale) / 2 in (floor(kw/2 * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw/2), floor(scale * y + centery + kh/2))) $ concat $ zipzip xys) getKeyLocationsAbs :: Integral a => a -> (Double, Double, [[(Double, Double)]]) getKeyLocationsAbs colsRepeat = let kb_rows = fromIntegral _AXIS_ROWS :: Double kb_cols = fromIntegral colsRepeat * fromIntegral _AXIS_UNIQUE_COLS :: Double -- the edges of the hexagon are equal in length to its "radius" -- if the radius is 1, then horizontal movement is 1.5 and vertical movement is sqrt(3) from one center to the next -- or else it is 2*sqrt(3) to move down kw = 1 :: Double kh = kw/2 * sqrt 3 -- hexagon ratio xys = map ((\y -> map (\i -> let repetition = i `div` fromIntegral _AXIS_UNIQUE_COLS odd = 1 == i `mod` 2 dropBy = if odd then kh / 2 + kh * fromInteger (repetition `div` 2) else kh * fromInteger ((repetition + 1) `div` 2) in ( fromInteger i * kw * 3 / 4, y + dropBy )) [0 .. round kb_cols - 1]) . (\i -> kh * fromIntegral i)) [0..round kb_rows - 1] in (kh, kw, xys) -- clear a band the width of the videoClipRect and print the text within it, centered textBand :: SDL.Surface -> SDL.Rect -> SDL.Rect -> SDL.TTF.Font -> String -> IO () textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do let (SDL.Rect vx _ vw _) = videoClipRect _ <- SDL.fillRect videoSurface (Just (SDL.Rect 0 y vw h)) (SDL.Pixel 0) Control.Monad.when (text /= "") $ do fontSurface <- SDL.TTF.renderUTF8Blended font text (SDL.Color 0 255 0) fontClipRect <- SDL.getClipRect fontSurface let (SDL.Rect _ fy fw _) = fontClipRect _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect ((vw - fw) `div` 2) y vw h)) return () return () parseSDLEvents :: Set.Set SDLKey -> (Int, Int) -> IO (Set.Set SDLKey, (Int, Int)) parseSDLEvents keysDown others = do event <- SDL.pollEvent case event of SDL.NoEvent -> return (keysDown, others) SDL.KeyDown (SDL.Keysym k _ _) -> parseSDLEvents (Set.insert k keysDown) others SDL.KeyUp (SDL.Keysym k _ _) -> parseSDLEvents (Set.delete k keysDown) others SDL.VideoResize w h -> parseSDLEvents keysDown (w, h) _ -> parseSDLEvents keysDown others keyDown :: SDL.Keysym.SDLKey -> Set.Set SDL.Keysym.SDLKey -> Bool keyDown = Set.member deriving instance Ord SDL.Keysym