{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE StandaloneDeriving #-} import Prelude hiding ((.), id, null, filter) 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 Data.String import Graphics.UI.SDL.Keysym as SDL.Keysym import Graphics.UI.SDL.Primitives as SDL.Primitive import Data.Int (Int16) import qualified System.Exit as Exit import Data.List (elemIndex, elemIndices, filter, groupBy, length, reverse, sort) import GHC.Word import Data.Bits import qualified Sound.ALSA.Sequencer.Event as Event import qualified Graphics.UI.SDL.Utilities as SDL.Util import qualified Data.Map as Map smartShowPitch p = showPitch p -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars _USE_HEXAGONS = True _LABEL_WHILE_PLAYING = True _LABEL_ALL_KEYS = False _AXIS_ROWS = 7 + 4 _AXIS_UNIQUE_COLS = 7 _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 = (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 = 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 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 = _KEY_ON_COLOR : (tail _CGA) _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 = _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 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 (\ (_, p) -> p) $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys) playingNowChans n = Set.map (\ (c, _) -> c) $ 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 = length chans == 0 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 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 a1, Integral a2, Integral a) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> t -> Maybe String -> [Int] -> IO () drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text channels = do let (x, y) = axis_key_locations !! idx 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) $ do 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 () fi = fromIntegral rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. (fi 255)) chooseFontSize h w = 30 * d `div` 1024 where d = min h w data LoopState = LoopState { firstLoop :: Bool, repeatCols :: Integer } deriving (Show) _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 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 = do _ <- SDL.warpMouse (fromIntegral (sWidth `div` 2)) (fromIntegral (sHeight `div` 2)) return () setVideoMode w h = SDL.setVideoMode w h 32 [SDL.HWSurface, SDL.Resizable, SDL.DoubleBuf] _ <- setVideoMode sWidth sHeight _ <- SDL.TTF.init font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" (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 putStrLn "Initialized." let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) let loop state midiKeysDown keysDown resolution font = do let (LoopState firstLoop colsRepeat) = state (keysDown', resolution') <- parseSDLEvents keysDown resolution midiKeysDown' <- parseAlsa midiKeysDown let colsRepeat' = case firstDigitDown keysDown' of Nothing -> colsRepeat; (Just 0) -> colsRepeat; (Just n) -> n; let restartVideo = resolution' /= resolution || colsRepeat' /= colsRepeat Control.Monad.when restartVideo $ do let (w, h) = resolution' _ <- setVideoMode w h return () let (w, h) = resolution' fontSize = chooseFontSize w h font' <- (if (restartVideo) then SDL.TTF.openFont "LiberationMono-Bold.ttf" fontSize else return font) videoSurface <- SDL.getVideoSurface videoClipRect <- 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 Control.Monad.when(firstLoop) allKeysOFF -- Control.Monad.when (x /= x' && x' /= "") $ do -- textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x' -- return () let chanfilter = Set.filter (\ (c, _) -> c /= (Event.Channel 9)) beforeKeys = chanfilter midiKeysDown nowKeys = chanfilter midiKeysDown' changedPitches = Set.map (\ (_, p) -> p) $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys) playingNowChans n = Set.map (\ (c, _) -> c) $ 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 Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do -- let chord = showChord midiKeysDown' -- let chord = show $ pitchList midiKeysDown' -- let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown' -- textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size return () Control.Monad.when (restartVideo) $ do allKeysOFF smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size return () Control.Monad.when (keysDown' /= keysDown) $ do Control.Monad.when (keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF Control.Monad.when (keyDown SDL.SDLK_c keysDown') allKeysReallyOFF -- 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 -- -- mouse <- SDL.getRelativeMouseState -- let (x, y, button) = mouse -- let text = ((show x) ++ " " ++ (show y) ++ " " ++ (show button)) -- textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font text -- Control.Monad.when (x /= 0 || y /= 0) warpMouse _ <- SDL.flip videoSurface let framerate = 30 let delay = 1000 `div` framerate -- TODO: subtract delta SDL.delay (delay) Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $ loop (LoopState False colsRepeat') midiKeysDown' keysDown' resolution' font' loop (LoopState True _AXIS_COLS_REPEAT) Set.empty Set.empty (sWidth, sHeight) font zipzip ls = if (head ls) == [] then [] else (map head ls) : (zipzip $ map tail ls) 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, 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] (if not filled then SDL.Primitive.polygon else SDL.Primitive.filledPolygon) videoSurface points pixel 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 colsRepeat = concat $ map (\x -> 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) $ map (* (-7)) [0 .. _AXIS_ROWS - 1] unique = concat $ map colfrom toprow 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 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]) $ map (\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 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 k s = Set.member k s deriving instance Ord SDL.Keysym