content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE OverloadedStrings          #-}
  --------------------------------------------------------------------------------
  -- |
  -- Module : Dhek.Mode.Normal
  --
  --------------------------------------------------------------------------------
  module Dhek.Mode.Normal (normalModeManager) where
  
  --------------------------------------------------------------------------------
  import Prelude hiding (mapM_)
  
  --------------------------------------------------------------------------------
  import           Control.Applicative
  import           Data.Foldable (find, for_, mapM_)
  import           Data.IORef
  import qualified Data.IntMap as I
  import           Data.Traversable
  
  --------------------------------------------------------------------------------
  import           Control.Lens      hiding (Action, act)
  import           Control.Monad.RWS hiding (mapM_)
  import           Data.Text (Text, pack)
  import qualified Graphics.Rendering.Cairo as Cairo
  import qualified Graphics.UI.Gtk          as Gtk
  
  --------------------------------------------------------------------------------
  import Dhek.Cartesian
  import Dhek.Engine.Instr
  import Dhek.Engine.Misc.LastHistory
  import Dhek.Engine.Type
  import Dhek.Geometry
  import Dhek.GUI
  import Dhek.GUI.Action
  import Dhek.I18N
  import Dhek.Mode.Common.Draw
  import Dhek.Mode.DuplicateKey
  import Dhek.Mode.Effect.Collision
  import Dhek.Mode.Effect.Magnetic
  import Dhek.Types
  import Dhek.Utils (findDelete)
  
  --------------------------------------------------------------------------------
  data Input
      = Input
        { inputGUI        :: GUI
        , inputCurModeMgr :: IORef (Maybe ModeManager)
        , inputAction     :: IORef (Maybe Action)
        }
  
  --------------------------------------------------------------------------------
  data Effect
      = Col Collide
      | Att Attract
      | None
  
  --------------------------------------------------------------------------------
  data Transform
      = Moving Rect Effect Vector2D
      | Resizing Rect Area Vector2D
  
  --------------------------------------------------------------------------------
  data Action
      = Drawing Vector2D
      | Transform Transform
      | MoveGuide Guide
  
  --------------------------------------------------------------------------------
  newtype NormalMode a
      = NormalMode (RWST Input () EngineState IO a)
      deriving ( Functor
               , Applicative
               , Monad
               , MonadReader Input
               , MonadState EngineState
               , MonadIO
               )
  
  --------------------------------------------------------------------------------
  instance ModeMonad NormalMode where
      mMove opts
          = runOrMode (normalMove opts) (move opts)
  
      mPress opts
          = runOrMode (normalPress opts) (press opts)
  
      mRelease opts
          = runOrMode (normalRelease opts) (release opts)
  
      mDrawing page ratio
          = runOrMode (normalDrawing page ratio) (drawing page ratio)
  
      mKeyPress kb
          = do input <- ask
               let g   = inputGUI input
                   ref = inputCurModeMgr input
               opt <- liftIO $ readIORef ref
               case opt of
                   Just _ -> return ()
                   -- Duplication mode use ALT modifier
                   _ -> when (statusNamePressed $ kbKeyName kb) $ liftIO $
                            do mgr <- duplicateKeyModeManager g
                               writeIORef ref $ Just mgr
                               isOverDrawingArea <- overDrawingArea g
                               when isOverDrawingArea $
                                   do _ <- Gtk.statusbarPush (guiStatusBar g)
                                           (guiContextId g)
                                           (guiTranslate g MsgDupHelp)
                                      Gtk.widgetShowAll $ guiDrawPopup g
                                      updatePopupPos g
                                      gtkSetDhekCursor g (Just $ DhekCursor CursorDup)
  
      mKeyRelease kb
          = do input <- ask
               let g   = inputGUI input
                   ref = inputCurModeMgr input
               opt <- liftIO $ readIORef ref
               case opt of
                   Nothing -> return ()
                   -- In Duplication mode
                   Just mgr
                       -> when (statusNamePressed $ kbKeyName kb) $
                              do mgrCleanup mgr
                                 liftIO $
                                     do Gtk.statusbarPop (guiStatusBar g)
                                            (guiContextId g)
                                        Gtk.widgetHide $ guiDrawPopup g
                                        writeIORef ref Nothing
                                        gtkSetDhekCursor g Nothing
  
      mEnter
          = do input <- ask
               let g   = inputGUI input
                   ref = inputCurModeMgr input
               opt <- liftIO $ readIORef ref
               case opt of
                   Nothing -> return ()
                   -- In duplication mode
                   Just _
                       -> liftIO $
                              do Gtk.widgetShowAll $ guiDrawPopup g
                                 updatePopupPos g
  
      mLeave
          = do input <- ask
               let g   = inputGUI input
                   ref = inputCurModeMgr input
               opt <- liftIO $ readIORef ref
               case opt of
                   Nothing -> return ()
                   -- In duplication mode
                   Just _
                       -> liftIO $ Gtk.widgetHide $ guiDrawPopup g
  
  --------------------------------------------------------------------------------
  runOrMode :: NormalMode () -> M () -> NormalMode ()
  runOrMode nm m
      = do ref <- asks inputCurModeMgr
           opt <- liftIO $ readIORef ref
           case opt of
               Nothing
                   -> nm
               Just mgr
                   -> do s <- get
                         let (Mode k) = mgrMode mgr
                         s' <- liftIO $ k m s
                         put s'
  
  --------------------------------------------------------------------------------
  magneticForce :: Double -> Double
  magneticForce ratio = 25 / ratio
  
  --------------------------------------------------------------------------------
  normalMove :: DrawEnv -> NormalMode ()
  normalMove env
      = do actRef  <- asks inputAction
           mAct    <- liftIO $ readIORef actRef
           mNewAct <- traverse (normalOnAction env) mAct
  
           liftIO $ writeIORef actRef mNewAct
           maybe (normalNoAction env) normalSetActionCursor mNewAct
  
  --------------------------------------------------------------------------------
  normalOnAction :: DrawEnv -> Action -> NormalMode Action
  normalOnAction env act
      = do magnet <- use engineMagnetic
           if magnet
               then magneticAction env act
               else normalActionDispatch env act
  
  --------------------------------------------------------------------------------
  normalActionDispatch :: DrawEnv -> Action -> NormalMode Action
  normalActionDispatch env act
      = case act of
            Drawing v   -> normalDrawSelection env v
            MoveGuide g -> normalMoveGuide g
            Transform t -> normalTransform env t
  
  --------------------------------------------------------------------------------
  magneticAttract :: DrawEnv -> Action -> NormalMode (Maybe Action)
  magneticAttract env act
      = do gs <- engineStateGetGuides
           let ls = fmap toLine gs
           case act of
               Drawing v
                   -> return $ attractDraw env v ls
               MoveGuide _
                   -> return Nothing
               Transform t
                   -> case t of
                          Moving r _ v
                              -> return $ attractMove env r v ls
                          Resizing r a v
                              -> return $ attractResize env r a v ls
    where
      toLine g
          = case g ^. guideType of
                GuideVertical   -> verticalLine (g ^. guideValue)
                GuideHorizontal -> horizontalLine (g ^. guideValue)
  
  --------------------------------------------------------------------------------
  attractMove :: DrawEnv -> Rect -> Vector2D -> [Line] -> Maybe Action
  attractMove env r v ls
      = fmap go mAtt
    where
      go att  = Transform $ Moving r (Att att) newVect
      mAtt    = magneticAttraction (magneticMove r newVect) force ls
      pt      = drawPointer env
      ratio   = drawRatio env
      newVect = v & vectorTo .~ pt
      force   = magneticForce ratio
  
  --------------------------------------------------------------------------------
  attractDraw :: DrawEnv -> Vector2D -> [Line] -> Maybe Action
  attractDraw _ _ _
      = Nothing
    -- where
    --   mAtt = magneticAttraction (magneticDraw v) ls
  
  --------------------------------------------------------------------------------
  attractResize :: DrawEnv -> Rect -> Area -> Vector2D -> [Line] -> Maybe Action
  attractResize _ _ _ _ _
      = Nothing
    -- where
    --   mAtt = magneticAttraction (magneticResize r a v) ls
  
  --------------------------------------------------------------------------------
  magneticAction :: DrawEnv -> Action -> NormalMode Action
  magneticAction env act
      = do mAtt <- magneticAttract env act
           case mAtt of
               Nothing     -> normalActionDispatch env act
               Just newAct -> return newAct
  
  --------------------------------------------------------------------------------
  normalSetActionCursor :: Action -> NormalMode ()
  normalSetActionCursor act
      = do gui <- asks inputGUI
           liftIO $ gtkSetDhekCursor gui $ normalActionCursor act
  
  --------------------------------------------------------------------------------
  normalNoAction :: DrawEnv -> NormalMode ()
  normalNoAction env
      = do gui <- asks inputGUI
           gs  <- engineStateGetGuides
  
           let ogOpt = find (isOverGuide gRange env) gs
           engineDrawState.drawOverRect  .= oOpt
           engineDrawState.drawOverGuide .= ogOpt
           liftIO $ gtkSetDhekCursor gui $ cursor ogOpt
    where
      oOpt         = getOverRect env
      aOpt         = getOverArea env
      gRange       = guideRange env
      cursor ogOpt = fmap (GTKCursor . areaCursor) aOpt <|>
                     (GTKCursor Gtk.Hand1) <$ oOpt      <|>
                     (GTKCursor Gtk.Hand1) <$ ogOpt
  
  --------------------------------------------------------------------------------
  normalActionCursor :: Action -> Maybe DhekCursor
  normalActionCursor act
      = case act of
            Transform t ->
                case t of
                    Moving _ _ _   -> Just $ GTKCursor Gtk.Hand1
                    Resizing _ a _ -> Just $ GTKCursor $ areaCursor a
            MoveGuide _ -> Just $ GTKCursor Gtk.Hand1
            _           -> Nothing
  
  --------------------------------------------------------------------------------
  normalMoveGuide :: Guide -> NormalMode Action
  normalMoveGuide g
      = do gui <- asks inputGUI
           x   <- liftIO $ Gtk.get (guiHRuler gui) Gtk.rulerPosition
           y   <- liftIO $ Gtk.get (guiVRuler gui) Gtk.rulerPosition
  
           engineDrawState.drawOverGuide .= Nothing
  
           let newValue =
                   case g ^. guideType of
                       GuideVertical   -> x
                       GuideHorizontal -> y
           return $ MoveGuide (g & guideValue .~ newValue)
  
  --------------------------------------------------------------------------------
  normalTransform :: DrawEnv -> Transform -> NormalMode Action
  normalTransform env t
      = do overlap <- use engineOverlap
           if overlap
               then
               case t of
                   Moving r _ v   -> normalOverlapMove env r v
                   Resizing r a v -> normalOverlapResize env r a v
               else
               case t of
                   Moving r _ v   -> normalCollisionMove env r v
                   Resizing r a v -> normalOverlapResize env r a v
  
  --------------------------------------------------------------------------------
  normalOverlapMove :: DrawEnv -> Rect -> Vector2D -> NormalMode Action
  normalOverlapMove env r v = return $ Transform $ Moving r None newVect
    where
      pos     = drawPointer env
      newVect = v & vectorTo .~ pos
  
  --------------------------------------------------------------------------------
  normalOverlapResize :: DrawEnv -> Rect -> Area -> Vector2D -> NormalMode Action
  normalOverlapResize env r a v = return $ Transform $ Resizing r a newVect
    where
      pos     = drawPointer env
      newVect = v & vectorTo .~ pos
  
  --------------------------------------------------------------------------------
  normalCollisionMove :: DrawEnv -> Rect -> Vector2D -> NormalMode Action
  normalCollisionMove env r v
      = case inter of
          Nothing
              -> normalOverlapMove env r v
          Just c
              -> return $ Transform $ Moving r (Col c) newVect
    where
      pos     = drawPointer env
      newVect = v & vectorTo .~ pos
      rs      = drawRects env
      inter   = collisionCollide (collisionMove r newVect) rs
  
  --------------------------------------------------------------------------------
  normalDrawSelection :: DrawEnv -> Vector2D -> NormalMode Action
  normalDrawSelection env v
      = return $ Drawing newVect
    where
      pos     = drawPointer env
      newVect = v & vectorTo .~ pos
  
  --------------------------------------------------------------------------------
  -- | if user:
  --      - click on nothing: we're in drawing mode
  --      - click on a guide: guide is selected
  --      - click on a rectangle: we enter in event mode (Resize or Hold)
  normalPress :: DrawEnv -> NormalMode ()
  normalPress env
      = maybe (normalPressNoRect env) (normalPressRect env) oOpt
    where
      oOpt = getOverRect env
  
  --------------------------------------------------------------------------------
  normalDetectAction :: DrawEnv -> Rect -> Action
  normalDetectAction env r
      = maybe moving resizing aOpt
    where
      pos        = drawPointer env
      aOpt       = getOverArea env
      newVect    = vector2D pos pos
      moving     = Transform $ Moving r None newVect
      resizing a = Transform $ Resizing r a newVect
  
  --------------------------------------------------------------------------------
  normalPressRect :: DrawEnv -> Rect -> NormalMode ()
  normalPressRect env r
      = do pid    <- use engineCurPage
           actRef <- asks inputAction
  
           engineBoards.boardsMap.at pid.traverse.boardRects.at rid .= Nothing
           liftIO $ writeIORef actRef $ Just act
    where
      act = normalDetectAction env r
      rid = r ^. rectId
  
  --------------------------------------------------------------------------------
  normalNoRectDetectAction :: DrawEnv -> [Guide] -> (Action, [Guide])
  normalNoRectDetectAction env guides
      = case gOpt of
            Just g  -> (MoveGuide g, newGuides)
            Nothing -> (Drawing vect, guides)
    where
      (gOpt, newGuides)  = findOveredGuide guides
      findOveredGuide gs = findDelete (isOverGuide gRange env) gs
      gRange             = guideRange env
      pt                 = drawPointer env
      vect               = vector2D pt pt
  
  --------------------------------------------------------------------------------
  normalPressNoRect :: DrawEnv -> NormalMode ()
  normalPressNoRect env
      = do gs     <- engineStateGetGuides
           actRef <- asks inputAction
           let (act, gs') = normalNoRectDetectAction env gs
  
           liftIO $ writeIORef actRef $ Just act
           engineStateSetGuides gs'
  
  --------------------------------------------------------------------------------
  normalTransformRelease :: Transform -> NormalMode ()
  normalTransformRelease t
      = do pid <- use engineCurPage
  
           let r = case t of
                   Moving r' mC v
                       -> case mC of
                               None
                                   -> moveRect v r'
                               Col c
                                   -> projectCollision (collisionMove r' v ) c
                               Att a
                                   -> projectMagnetic (magneticMove r' v) a
                   Resizing r' a v
                       -> normalize $ resizeRect a v r'
               rid = r ^. rectId
  
           engineBoards.boardsMap.at pid.traverse.boardRects.at rid ?= r
           engineEventStack %= (UpdateRectPos:)
  
           normalSelectRectangle r
  
  --------------------------------------------------------------------------------
  normalDrawingRelease :: Vector2D -> NormalMode ()
  normalDrawingRelease v
      = when (w*h >= 30) $
            do rid <- engineDrawState.drawFreshId <+= 1
               let r1 = r & rectId   .~ rid
                          & rectName %~ (<> (pack $ show rid))
  
               -- New rectangle
               gui <- asks inputGUI
               pid <- use engineCurPage
  
               engineBoards.boardsMap.at pid.traverse.boardRects.at rid ?= r1
               engineEventStack %= (CreateRect:)
  
               liftIO $ gtkAddRect r1 gui
               normalSelectRectangle r1
    where
      r = makeDrawSelectionRect v
      w = r ^. rectWidth
      h = r ^. rectHeight
  
  --------------------------------------------------------------------------------
  normalGuideRelease :: Guide -> NormalMode ()
  normalGuideRelease g
      = do gs <- engineStateGetGuides
           engineStateSetGuides (g:gs)
  
  --------------------------------------------------------------------------------
  normalRelease :: DrawEnv -> NormalMode ()
  normalRelease _
      = do actRef <- asks inputAction
           mAct   <- liftIO $ readIORef actRef
  
           for_ mAct $ \act ->
               case act of
                   Transform t -> normalTransformRelease t --  r
                   Drawing v   -> normalDrawingRelease v
                   MoveGuide g -> normalGuideRelease g
  
           liftIO $ writeIORef actRef Nothing
  
  --------------------------------------------------------------------------------
  normalDrawing :: PageItem -> Ratio -> NormalMode ()
  normalDrawing page ratio
      = do gui    <- asks inputGUI
           actRef <- asks inputAction
           mAct   <- liftIO $ readIORef actRef
           ds     <- use $ engineDrawState
           pid    <- use $ engineCurPage
           bd     <- use $ engineBoards.boardsMap.at pid.traverse
           mSid   <- use $ engineDrawState.drawSelected.to lhPeek
           let curGuide  = mAct >>= actionGetGuide
               rects     = bd ^. boardRects.to I.elems
               overGuide = ds ^. drawOverGuide
  
           liftIO $ do
               frame     <- Gtk.widgetGetDrawWindow $ guiDrawingArea gui
               (fw',fh') <- Gtk.drawableGetSize frame
  
               let width  = ratio * (pageWidth page)
                   height = ratio * (pageHeight page)
                   fw     = fromIntegral fw'
                   fh     = fromIntegral fh'
                   eventR = mAct >>= transGetRect
                   area   = guiDrawingArea gui
  
               Gtk.widgetSetSizeRequest area (truncate width) (truncate height)
               Gtk.renderWithDrawable frame $ do
                   suf <- guiPdfSurface page ratio gui
                   Cairo.setSourceSurface suf 0 0
                   Cairo.paint
  
                   Cairo.scale ratio ratio
                   mapM_ (drawGuide fw fh rgbGreen) overGuide
                   Cairo.closePath
                   Cairo.stroke
                   mapM_ (drawGuide fw fh selectedColor) curGuide
                   Cairo.closePath
                   Cairo.stroke
  
                   -- Draw the entire board
                   for_ rects $ \r ->
                       case () of
                           _ | Just (r ^. rectId) == mSid -> do
                               drawRect selectedColor Line r
  
                             | Just r == ds ^. drawOverRect ->
                               drawRect overedColor Line r
  
                             | otherwise ->
                                 drawRect regularColor Line r
  
                   -- Draw drawing selection rectangle
                   for_ (mAct >>= drawingGetRect) $ \r -> do
                       drawRect selectionColor Line r
                       drawRectGuides fw fh rectGuideColor r
  
                   -- Draw event rectangle
                   for_ eventR $ \r -> do
                       drawRect selectedColor Line r
                       drawRectGuides fw fh rectGuideColor r
    where
      overedColor    = RGB 0.16 0.72 0.92
      regularColor   = rgbBlue
      selectedColor  = rgbRed
      selectionColor = rgbGreen
      rectGuideColor = RGB 0.16 0.72 0.92
  
  --------------------------------------------------------------------------------
  runNormal :: Input -> NormalMode a -> EngineState -> IO EngineState
  runNormal input (NormalMode m) s
      = do (s', _) <- execRWST m input s
           return s'
  
  --------------------------------------------------------------------------------
  normalMode :: Input -> Mode
  normalMode gui = Mode (runNormal gui . runM)
  
  --------------------------------------------------------------------------------
  normalModeManager :: GUI -> IO ModeManager
  normalModeManager gui
      = do mgrRef <- newIORef Nothing
           actRef <- newIORef Nothing
  
           -- Display normal Help message
           Gtk.statusbarPop (guiStatusBar gui) (guiContextId gui)
           _ <- Gtk.statusbarPush (guiStatusBar gui) (guiContextId gui)
                (guiTranslate gui MsgDrawHelp)
  
           let input = Input
                       { inputGUI         = gui
                       , inputCurModeMgr  = mgrRef
                       , inputAction      = actRef
                       }
           return $ ModeManager (normalMode input) (return ())
  
  --------------------------------------------------------------------------------
  normalSelectRectangle :: Rect -> NormalMode ()
  normalSelectRectangle r = do
      engineDrawState.drawSelected %= lhPush (r ^. rectId)
      gui <- asks inputGUI
      liftIO $ gtkSelectRect r gui
  
  --------------------------------------------------------------------------------
  -- | Guide range detection in pixels
  guideRange :: DrawEnv -> Double
  guideRange opts
      = 10 / ratio where ratio = drawRatio opts
  
  --------------------------------------------------------------------------------
  statusNamePressed :: Text -> Bool
  statusNamePressed n
      | "Alt_L" <- n = True
      | "Alt_R" <- n = True
      | otherwise    = False
  
  --------------------------------------------------------------------------------
  isOverGtkRect :: (Int, Int) -> Gtk.Rectangle -> Bool
  isOverGtkRect (x,y) (Gtk.Rectangle rx ry rw rh)
      = rx <= x && x <= rx + rw &&
        ry <= y && y <= ry + rh
  
  --------------------------------------------------------------------------------
  overDrawingArea :: GUI -> IO Bool
  overDrawingArea g
      = do pos    <- Gtk.widgetGetPointer $ guiWindow g
           size   <- Gtk.widgetGetSize $ guiDrawingAreaViewport g
           mcoord <- Gtk.widgetTranslateCoordinates
                     (guiDrawingArea g) (guiWindow g) 0 0
  
           return $ maybe False (calculate pos size) mcoord
    where
      calculate pos (rw, rh) (x,y)
          = isOverGtkRect pos (Gtk.Rectangle x y rw rh)
  
  --------------------------------------------------------------------------------
  transGetRect :: Action -> Maybe Rect
  transGetRect (Transform t)
      = case t of
            Moving r mC v
                -> case mC of
                        None  -> Just $ moveRect v r
                        Col c -> Just $ projectCollision (collisionMove r v) c
                        Att a -> Just $ projectMagnetic (magneticMove r v) a
            Resizing r a v -> Just $ resizeRect a v r
  transGetRect _ = Nothing
  
  --------------------------------------------------------------------------------
  drawingGetRect :: Action -> Maybe Rect
  drawingGetRect (Drawing v) = Just $ makeDrawSelectionRect v
  drawingGetRect _           = Nothing
  
  --------------------------------------------------------------------------------
  actionGetGuide :: Action -> Maybe Guide
  actionGetGuide (MoveGuide g) = Just g
  actionGetGuide _             = Nothing
  