path: root/axis.hs

{-# 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 ()
}

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 "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
      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 "LiberationMono-Bold.ttf" 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