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

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

  let pixelFormat = SDL.surfaceGetPixelFormat videoSurface
  blue <- SDL.mapRGB pixelFormat 0 255 255 -- why is it blue???
  -- _ <- SDL.setRelativeMouseMode True -- SDL2.  Should I use it?

  let (axis_key_size, axis_key_locations) = getKeyLocations videoClipRect

  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

  forM_ [0 .. length axis_key_locations - 1] $ \i -> do
    let (centerx, centery) = axis_key_locations !! i
    centerText videoSurface centerx centery font (showPitch $ pitchIndex !! i)
--  centerText videoSurface centerx centery font (show i)

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

centerText videoSurface x y font 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 (SDL.Color 0 255 0) (SDL.Color 0 0 0)
  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 ()

colfrom top = map (+ top) $ map (* (-7)) [0 .. 6]
pitchIndex = (\x -> x ++ x) $ concat $ map colfrom [81, 78, 82, 79, 83, 80, 84]

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