content: {-# LANGUAGE OverloadedStrings #-}
  
  module Main (main) where
  
  import qualified Common                 as C
  import qualified SDL
  
  import           Common                 (moveTo)
  import           Control.Monad.IO.Class (MonadIO)
  import           Control.Monad.Loops    (iterateUntilM)
  import           Data.Foldable          (foldl')
  
  
  -- Setup
  
  data Quadrant
    = TopLeft
    | TopRight
    | BottomLeft
    | BottomRight
  
  
  data Intent
    = Idle
    | Quit
    | Press Quadrant
    | Release Quadrant
    | Hover Quadrant
    | Leave Quadrant
  
  
  data Pane
    = Out
    | Over
    | Down
    | Up
  
  
  data PaneMap = PaneMap
    { topLeft     :: Pane
    , topRight    :: Pane
    , bottomLeft  :: Pane
    , bottomRight :: Pane
    }
  
  
  data World = World
    { exiting :: Bool
    , panes   :: PaneMap
    }
  
  
  initialPanes :: PaneMap
  initialPanes = PaneMap
    { topLeft     = Out
    , topRight    = Out
    , bottomLeft  = Out
    , bottomRight = Out
    }
  
  
  initialWorld :: World
  initialWorld = World
    { exiting = False
    , panes = initialPanes
    }
  
  
  -- Actions
  
  selectQuadrant :: (Num a, Ord a) => a -> a -> Quadrant
  selectQuadrant x y
    | x <  320 && y <  240 = TopLeft
    | x >= 320 && y <  240 = TopRight
    | x <  320 && y >= 240 = BottomLeft
    | x >= 320 && y >= 240 = BottomRight
    | otherwise            = undefined
  
  
  motionIntent :: SDL.MouseMotionEventData -> Intent
  motionIntent e = Hover q
    where
      q = selectQuadrant x y
      (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos e
  
  
    -- | SDL.mouseButtonEventMotion e == SDL.Pressed -> Down
    --
  buttonIntent :: SDL.MouseButtonEventData -> Intent
  buttonIntent e = t q
    where
      q = selectQuadrant x y
      (SDL.P (SDL.V2 x y)) = SDL.mouseButtonEventPos e
      t = if SDL.mouseButtonEventMotion e == SDL.Pressed
             then Press
             else Release
  
  
  payloadToIntent :: SDL.EventPayload -> Intent
  payloadToIntent SDL.QuitEvent            = Quit
  payloadToIntent (SDL.MouseMotionEvent e) = motionIntent e
  payloadToIntent (SDL.MouseButtonEvent e) = buttonIntent e
  payloadToIntent _                        = Idle
  
  
  setOut :: Pane -> Pane
  setOut Down = Down
  setOut _    = Out
  
  
  setOver :: Pane -> Pane
  setOver Down = Down
  setOver Up   = Up
  setOver _    = Over
  
  
  setDown :: Pane -> Pane
  setDown _ = Down
  
  
  setUp :: Pane -> Pane
  setUp Down = Up
  setUp p    = p
  
  
  updatePaneMap :: (Pane -> Pane) -> (Pane -> Pane) -> Quadrant -> PaneMap -> PaneMap
  updatePaneMap f g TopLeft     (PaneMap tl tr bl br) = PaneMap (f tl) (g tr) (g bl) (g br)
  updatePaneMap f g TopRight    (PaneMap tl tr bl br) = PaneMap (g tl) (f tr) (g bl) (g br)
  updatePaneMap f g BottomLeft  (PaneMap tl tr bl br) = PaneMap (g tl) (g tr) (f bl) (g br)
  updatePaneMap f g BottomRight (PaneMap tl tr bl br) = PaneMap (g tl) (g tr) (g bl) (f br)
  
  
  pressWorld :: Quadrant -> World -> World
  pressWorld q w = w { panes = panes' }
    where panes' = updatePaneMap setDown id q (panes w)
  
  
  releaseWorld :: Quadrant -> World -> World
  releaseWorld q w = w { panes = panes' }
    where panes' = updatePaneMap setUp id q (panes w)
  
  
  hoverWorld :: Quadrant -> World -> World
  hoverWorld q w = w { panes = panes' }
    where panes' = updatePaneMap setOver setOut q (panes w)
  
  
  leaveWorld :: Quadrant -> World -> World
  leaveWorld q w = w { panes = panes' }
    where panes' = updatePaneMap setOut setOver q (panes w)
  
  
  quitWorld :: World -> World
  quitWorld w = w { exiting = True }
  
  
  applyIntent :: Intent -> World -> World
  applyIntent (Press q)   = pressWorld q
  applyIntent (Release q) = releaseWorld q
  applyIntent (Hover q)   = hoverWorld q
  applyIntent (Leave q)   = leaveWorld q
  applyIntent Idle        = id
  applyIntent Quit        = quitWorld
  
  
  updateWorld :: World -> [SDL.Event] -> World
  updateWorld w
    = foldl' (flip applyIntent) w
    . fmap (payloadToIntent . SDL.eventPayload)
  
  
  -- Rendering
  
  getMask :: (Num a) => Pane -> (a, a)
  getMask Out  = (  0,   0)
  getMask Over = (320,   0)
  getMask Down = (  0, 240)
  getMask Up   = (320, 240)
  
  
  getPosition :: (Num a) => Quadrant -> (a, a)
  getPosition TopLeft     = (  0,   0)
  getPosition TopRight    = (320,   0)
  getPosition BottomLeft  = (  0, 240)
  getPosition BottomRight = (320, 240)
  
  
  drawWorld :: (MonadIO m) => SDL.Renderer -> (SDL.Texture, SDL.TextureInfo) -> World -> m ()
  drawWorld r (t, ti) w = do
    renderPane (topLeft     $ panes w) TopLeft
    renderPane (topRight    $ panes w) TopRight
    renderPane (bottomLeft  $ panes w) BottomLeft
    renderPane (bottomRight $ panes w) BottomRight
  
      where
        tw :: Double
        tw = fromIntegral $ SDL.textureWidth ti
        th = fromIntegral $ SDL.textureHeight ti
  
        s = C.mkRect 0 0 (tw / 2) (th / 2)
  
        mFor c = s `moveTo` getMask c
        pFor c = s `moveTo` getPosition c
  
        renderPane p q
          = SDL.copy r t
              (Just $ floor <$> mFor p)
              (Just $ floor <$> pFor q)
  
  
  renderWorld :: (MonadIO m) => SDL.Renderer -> (SDL.Texture, SDL.TextureInfo) -> World -> m ()
  renderWorld r t w = do
    SDL.clear r
    drawWorld r t w
    SDL.present r
  
  
  -- Main
  
  main :: IO ()
  main = C.withSDL $ C.withSDLImage $ do
    C.setHintQuality
    C.withWindow "Lesson 17" (640, 480) $ \w ->
      C.withRenderer w $ \r -> do
        t <- C.loadTextureWithInfo r "./assets/mouse_states.png"
  
        let doRender = renderWorld r t
  
        _ <- iterateUntilM
          exiting
          (\x ->
            updateWorld x <$> SDL.pollEvents
            >>= \x' -> x' <$ doRender x'
          )
          initialWorld
  
        SDL.destroyTexture (fst t)
  