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

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
      warpMouse = do
        _ <- SDL.warpMouse (fromIntegral (width `div` 2)) (fromIntegral (height `div` 2))
        return ()
  screen <- SDL.setVideoMode width height 32 [SDL.SWSurface, SDL.Fullscreen]

  _ <- 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
  -- _ <- SDL.setRelativeMouseMode True -- SDL2.  Should I use it?

  let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect
  print getKeyLocationsAbs
  print axis_key_locations

  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'
          textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
          return ()

        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
          return ()

        textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $
          if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else ""

        mouse <- SDL.getRelativeMouseState
        let (x, y, button) = mouse
        textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font ((show x) ++ " " ++ (show y) ++ " " ++ (show button))
        Control.Monad.when (x /= 0 || y /= 0) warpMouse

        let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
        blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue???
        forM_ axis_key_locations $ \(x, y) -> do
          --SDL.Primitive.filledCircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return
          drawHexagonSDL videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) blue >>= return

        _ <- SDL.updateRect videoSurface videoClipRect -- draw it all!

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

drawHexagonSDL videoSurface centerx centery radius pixel = do
  let r = fromIntegral radius
--let points = map (\(x, y) -> (centerx + x + radius `div` 2, centery + y + radius `div` 2)) $
  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]
  --filledPolygon :: Surface -> [(Int16, Int16)] -> Pixel -> IO Bool
  SDL.Primitive.polygon videoSurface points pixel >>= return

  let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
  blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue???
  SDL.Primitive.filledCircle videoSurface (fromIntegral centerx) (fromIntegral centery) 10 blue >>= return
  SDL.Primitive.filledCircle videoSurface 0 0 10 blue >>= return

  font <- SDL.TTF.openFont "LiberationMono-Bold.ttf" 30
  centerText videoSurface centerx centery font "OK!"
  return ()

centerText videoSurface x y font text = do
  fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80)
  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))
--_ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) + w) (fromIntegral(y) + h `div` 2) w h))
  return ()


getKeyLocations (SDL.Rect offx offy totalw totalh) =
  let (key_height, key_width, xys) = getKeyLocationsAbs

      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, each step is 1.5 horizontal, plus 2 halfs to fill to the edges
      -- thus the keyboard is radius * (numkeys - 1) * 1.5 + 1)
      keyboard_width = (fromIntegral(kb_cols - 1) * 1.5 + 2) * key_width
      keyboard_height = fromIntegral(kb_rows + 1) * key_height -- half of the keyboard is offset down one key

      fit_width = fromIntegral(totalh) / fromIntegral(totalw) > keyboard_height / keyboard_width
      scale = if fit_width
              then fromIntegral(totalw) / keyboard_width
              else fromIntegral(totalh) / keyboard_height

      kh = key_height * scale
      kw = key_width * scale

      centerx = (fromIntegral(totalw) - keyboard_width * scale) / 2
      centery = (fromIntegral(totalh) - keyboard_height * scale) / 2
    in
      (floor(kw * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw), floor(scale * y + centery + kh/2))) $ concat xys)

getKeyLocationsAbs =
  let kb_rows = 7 :: Double
      kb_cols = 14 :: 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 up

      kw = 1 :: Double
      kh = kw * sqrt(3) -- hexagon ratio

      xys =
            map (\y -> map (\i -> (

                fromInteger(i) * kw * 3 / 2,

                y + kh / 2 * fromInteger(i `mod` 2) +

                  (if (fromInteger(i) >= kb_cols / 2) 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