{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE StandaloneDeriving #-} import FRP.Netwire hiding (when) import Prelude hiding ((.), id, null, filter) import Data.Time.Clock import Control.Wire hiding (when) import Control.Wire.Session 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) import GHC.Word import Data.Bits import qualified Sound.ALSA.Sequencer.Event as Event netwireIsCool :: (Monad m) => Wire (Timed NominalDiffTime ()) () m a String netwireIsCool = for 2.5 . pure "Once upon a time..." --> for 3 . pure "... games were completely imperative..." --> for 2 . pure "... but then..." --> for 10 . (pure "Netwire 5! " <> anim) --> netwireIsCool where anim = 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 _COLORIZE_BY_CHANNEL = True _AXIS_ROWS = 7 + 4 _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_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 0xD0 0xD0 0xFF) -- D 8 -> _CGA !! 1 -- G# x | inMajorC x -> (SDL.Color 0xE0 0xE0 0xE0) -- _CGA !! 7 _ -> _CGA !! 8 smartDrawKeys reallyErase drawSet eraseSet videoSurface font axis_key_locations axis_key_size = do let drawList = filter (\ (c, _) -> unChannel c /= 9) $ Set.toList drawSet 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) pitch = if _OCTAVE_SQUASH then (unPitch n) `mod` 12 + 12 * 6 else (unPitch n) chann = unChannel c onColor = if _COLORIZE_BY_CHANNEL then _CHAN_TO_COLOR !! ((fromIntegral chann) `mod` 16) else _KEY_ON_COLOR offColor = pitchToColor pitch forM_ (elemIndices pitch pitchIndex) $ \idx -> do drawKey idx videoSurface font axis_key_locations axis_key_size (if erase then (if reallyErase then _KB_BG_COLOR else offColor) else onColor) (if reallyErase then _KB_BG_COLOR_PIXEL else _KEY_BORDER_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 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 SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ do info <- SDL.getVideoInfo let width = SDL.videoInfoWidth info height = SDL.videoInfoHeight info warpMouse = do _ <- SDL.warpMouse (fromIntegral (width `div` 2)) (fromIntegral (height `div` 2)) return () --screen <- SDL.setVideoMode width height 32 [SDL.SWSurface, SDL.Fullscreen] screen <- SDL.setVideoMode width height 32 [SDL.SWSurface] _ <- SDL.TTF.init font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" 30 videoSurface <- SDL.getVideoSurface videoClipRect <- SDL.getClipRect videoSurface --_ <- SDL.showCursor False --_ <- SDL.grabInput True --warpMouse --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 let _ALL_PITCHES = [_AXIS_BOTTOM_PITCH .. _AXIS_TOP_PITCH] let allKeysOFF = eraseKeys _ALL_PITCHES videoSurface font axis_key_locations axis_key_size allKeysReallyOFF = reallyEraseKeys _ALL_PITCHES videoSurface font axis_key_locations axis_key_size allKeysOFF putStrLn "Initialized." let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr) let loop midiKeysDown keysDown s w x = do keysDown' <- parseSDLEvents keysDown midiKeysDown' <- parseAlsa midiKeysDown (ds, s') <- stepSession s (ex, w') <- stepWire w ds (Right x) let x' = either (const "") id ex -- Control.Monad.when (x /= x' && x' /= "") $ do -- 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 chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown' -- textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord let ignoreThese = Set.intersection midiKeysDown' midiKeysDown let drawThese = Set.difference midiKeysDown' ignoreThese let eraseThese = Set.difference midiKeysDown ignoreThese smartDrawKeys False drawThese eraseThese videoSurface font axis_key_locations axis_key_size return () Control.Monad.when (keysDown' /= keysDown && keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF Control.Monad.when (keysDown' /= keysDown && 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.updateRect videoSurface videoClipRect -- draw it all! probably a bad idea let framerate = 30 let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds) SDL.delay (delay) Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $ loop midiKeysDown' keysDown' s' w' x' loop Set.empty Set.empty clockSession_ netwireIsCool "" 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 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 = concat $ map (\x -> unique) [0 .. _AXIS_COLS_REPEAT - 1] where toprow = map (\i -> if (i `mod` 2) == 0 then (_AXIS_TOP_PITCH + i `div` 2) else (_AXIS_TOP_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 (SDL.Rect offx offy totalw totalh) = let (key_height, key_width, xys) = getKeyLocationsAbs 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 = let kb_rows = (fromIntegral _AXIS_ROWS) :: Double kb_cols = _AXIS_COLS_REPEAT * (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 -> ( fromInteger(i) * kw * 3 / 4, y + kh / 2 * fromInteger(i `mod` 2) + (if (fromInteger(i) >= _AXIS_UNIQUE_COLS) then kh * fromInteger((i+1) `mod` 2) else 0) )) [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 SDL.SDLKey -> IO (Set.Set SDL.Keysym.SDLKey) parseSDLEvents keysDown = do event <- SDL.pollEvent case event of SDL.NoEvent -> return keysDown SDL.KeyDown (SDL.Keysym k _ _) -> parseSDLEvents (Set.insert k keysDown) SDL.KeyUp (SDL.Keysym k _ _) -> parseSDLEvents (Set.delete k keysDown) _ -> parseSDLEvents keysDown keyDown :: SDL.Keysym.SDLKey -> Set.Set SDL.Keysym.SDLKey -> Bool keyDown k s = Set.member k s deriving instance Ord SDL.Keysym