{-# 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

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!"

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
--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

  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
          putStrLn x'
          fontSurface <- SDL.TTF.renderUTF8Blended font x' (SDL.Color 0 255 0)
          fontClipRect <- SDL.getClipRect fontSurface
          _ <- SDL.fillRect videoSurface (Just (widenRect fontClipRect videoClipRect)) (SDL.Pixel 0) -- clear a horizontal band
          _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just fontClipRect)
          return ()

        Control.Monad.when (midiKeysDown' /= midiKeysDown) $ do
          let chord = showChord midiKeysDown'
          putStrLn chord
          if (chord /= "")
          then do
            chordFontSurface <- SDL.TTF.renderUTF8Blended font chord (SDL.Color 0 255 0)
            chordFontClipRect <- SDL.getClipRect chordFontSurface
            let r = chordFontClipRect `underNeath` (SDL.Rect 0 0 0 70)
            _ <- SDL.fillRect videoSurface (Just (widenRect r videoClipRect)) (SDL.Pixel 0) -- clear a horizontal band
            _ <- SDL.blitSurface chordFontSurface (Just chordFontClipRect) videoSurface (Just r)
            return ()
          else do
            _ <- SDL.fillRect videoSurface (Just (widenRect (SDL.Rect 0 70 0 70) videoClipRect)) (SDL.Pixel 0) -- clear a horizontal band
            return ()
          return ()

        _ <- SDL.updateRect videoSurface videoClipRect

        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 ""

widenRect a b =
  let ((SDL.Rect x1 y1 w1 h1), (SDL.Rect x2 _ w2 _)) = (a, b) in
    (SDL.Rect x2 y1 w2 h1)

underNeath a b =
  let ((SDL.Rect x1 y1 w1 h1), (SDL.Rect _ _ _ h2)) = (a, b) in
    (SDL.Rect x1 (y1+h2) w1 h1)

parseSDLEvents :: Set.Set SDL.Keysym -> IO (Set.Set SDL.Keysym)
parseSDLEvents keysDown = do
  event <- SDL.pollEvent
  case event of
    SDL.NoEvent -> return keysDown
    SDL.KeyDown k -> parseSDLEvents (Set.insert k keysDown)
    SDL.KeyUp k -> parseSDLEvents (Set.delete k keysDown)
    _ -> parseSDLEvents keysDown

keyDown :: SDL.SDLKey -> Set.Set SDL.Keysym -> Bool
keyDown k = not . Set.null . Set.filter ((== k) . SDL.symKey)

deriving instance Ord SDL.Keysym