content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE Rank2Types #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
  
  module Hoodle.Coroutine.Pen where
  
  import Control.Lens (at, over, set, view)
  import Control.Monad (when)
  import Control.Monad.State (MonadIO (liftIO), get)
  import Data.Foldable (toList)
  import Data.Functor.Identity (Identity (..))
  import Data.Hoodle.BBox
    ( BBox,
      getBBox,
      makeBBoxed,
    )
  import Data.Hoodle.Generic (gitems, gpages)
  import Data.Hoodle.Simple (Dimension (..))
  import qualified Data.IntMap as IM
  import Data.Ratio ((%))
  import Data.Sequence
    ( Seq (..),
      ViewL (..),
      empty,
      viewl,
      (|>),
    )
  import Data.Time.Clock
    ( NominalDiffTime,
      UTCTime,
      diffUTCTime,
      getCurrentTime,
    )
  import Graphics.Hoodle.Render (renderStrk, updateLayerBuf)
  import Graphics.Hoodle.Render.Type (RHoodle, RItem (..))
  import qualified Graphics.Rendering.Cairo as Cairo
  import Hoodle.Accessor
    ( pureUpdateUhdl,
      renderCache,
    )
  import Hoodle.Coroutine.Commit (commit)
  import Hoodle.Coroutine.Draw
    ( callRenderer_,
      invalidateAll,
      invalidateAllInBBox,
      nextevent,
    )
  import Hoodle.Device (PointerCoord (..))
  import Hoodle.GUI.Reflect (changeCurrentCanvasId)
  import Hoodle.ModelAction.Layer
    ( adjustCurrentLayer,
      getCurrentLayer,
    )
  import Hoodle.ModelAction.Page
    ( getPageFromGHoodleMap,
      updatePageAll,
    )
  import Hoodle.ModelAction.Pen
    ( TempRender (..),
      createNewStroke,
      tempInfo,
      tempSurfaceSrc,
      tempSurfaceTgt,
    )
  import Hoodle.Type.Canvas
    ( CanvasId,
      CanvasInfo,
      CanvasInfoBox,
      PenInfo,
      currentPageNum,
      drawArea,
      forBoth,
      forBoth',
      mDrawSurface,
      pageArrangement,
      unboxBiAct,
      unboxBiXform,
      unboxLens,
      viewInfo,
    )
  import Hoodle.Type.Coroutine (MainCoroutine)
  import Hoodle.Type.Enum
    ( DrawFlag (Efficient),
      PenColor (ColorRed),
    )
  import Hoodle.Type.Event (UserEvent (PenMove, PenUp))
  import Hoodle.Type.HoodleState
    ( HoodleModeState (ViewAppendState),
      HoodleState,
      currentCanvasInfo,
      currentUnit,
      getCanvasInfo,
      getCurrentCanvasId,
      getHoodle,
      penInfo,
      unitHoodles,
    )
  import Hoodle.Type.PageArrangement
    ( CanvasDimension (..),
      PageCoordinate (..),
      PageNum (..),
    )
  import Hoodle.Type.Predefined (dtimeBound)
  import Hoodle.Util (maybeFlip)
  import Hoodle.View.Coordinate
    ( CanvasGeometry
        ( canvasDim,
          desktop2Page
        ),
      device2Desktop,
      makeCanvasGeometry,
    )
  import Hoodle.View.Draw
    ( cairoXform4PageCoordinate,
      canvasImageSurface,
      doubleBufferFlush,
      emphasisCanvasRender,
      mkXform4Page,
      virtualDoubleBufferDraw,
    )
  import Prelude hiding (mapM_)
  
  -- |
  addPDraw ::
    CanvasId ->
    PenInfo ->
    RHoodle ->
    PageNum ->
    Seq (Double, Double, Double) ->
    -- | new hoodle and bbox in page coordinate
    MainCoroutine (RHoodle, BBox)
  addPDraw cid pinfo hdl (PageNum pgnum) pdraw = do
    let currpage = getPageFromGHoodleMap pgnum hdl
        currlayer = getCurrentLayer currpage
        newstroke = createNewStroke pinfo pdraw
        newstrokebbox = runIdentity (makeBBoxed newstroke)
        bbox = getBBox newstrokebbox
        newlayerbbox = over gitems (++ [RItemStroke newstrokebbox]) currlayer
    callRenderer_ $ updateLayerBuf cid newlayerbbox
    let newpagebbox = adjustCurrentLayer newlayerbbox currpage
        newhdlbbox = set gpages (IM.adjust (const newpagebbox) pgnum (view gpages hdl)) hdl
    return (newhdlbbox, bbox)
  
  -- |
  createTempRender :: CanvasGeometry -> a -> MainCoroutine (TempRender a)
  createTempRender geometry x = do
    xst <- get
    cache <- renderCache
    let uhdl = view (unitHoodles . currentUnit) xst
        cinfobox = view currentCanvasInfo uhdl
        mcvssfc = view (unboxLens mDrawSurface) cinfobox
        cid = getCurrentCanvasId uhdl
        hdl = getHoodle uhdl
        Dim cw ch = unCanvasDimension . canvasDim $ geometry
    srcsfc <-
      liftIO $
        maybe
          (fst <$> canvasImageSurface cache cid Nothing geometry hdl)
          ( \cvssfc -> do
              sfc <-
                Cairo.createImageSurface
                  Cairo.FormatARGB32
                  (floor cw)
                  (floor ch)
              Cairo.renderWith sfc $ do
                Cairo.setSourceSurface cvssfc 0 0
                Cairo.setOperator Cairo.OperatorSource
                Cairo.paint
              return sfc
          )
          mcvssfc
    liftIO $
      Cairo.renderWith srcsfc $ do
        emphasisCanvasRender ColorRed geometry
    tgtsfc <-
      liftIO $
        Cairo.createImageSurface
          Cairo.FormatARGB32
          (floor cw)
          (floor ch)
    let trdr = TempRender srcsfc tgtsfc (cw, ch) x
    return trdr
  
  -- | page switch if pen click a page different than the current page
  penPageSwitch :: PageNum -> MainCoroutine CanvasInfoBox
  penPageSwitch pgn = do
    xstate <- get
    let uhdl = view (unitHoodles . currentUnit) xstate
        cibox = view currentCanvasInfo uhdl
        ncibox = (runIdentity . forBoth unboxBiXform (return . set currentPageNum (unPageNum pgn))) cibox
        uhdl' = set currentCanvasInfo ncibox uhdl
    pureUpdateUhdl (const uhdl')
    invalidateAllInBBox Nothing Efficient
    return ncibox
  
  -- | Common Pen Work starting point
  commonPenStart ::
    forall b.
    ( forall a.
      CanvasInfo a ->
      PageNum ->
      CanvasGeometry ->
      (Double, Double) ->
      UTCTime ->
      MainCoroutine b
    ) ->
    CanvasId ->
    PointerCoord ->
    MainCoroutine (Maybe b)
  commonPenStart action cid pcoord = do
    oxstate <- get
    let currcid = (getCurrentCanvasId . view (unitHoodles . currentUnit)) oxstate
    ctime <- liftIO getCurrentTime
    when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll)
    nxstate <- get
    forBoth' unboxBiAct (f ctime) . getCanvasInfo cid . view (unitHoodles . currentUnit) $ nxstate
    where
      f :: forall c. UTCTime -> CanvasInfo c -> MainCoroutine (Maybe b)
      f ctime cvsInfo = do
        let cpn = PageNum . view currentPageNum $ cvsInfo
            arr = view (viewInfo . pageArrangement) cvsInfo
            canvas = view drawArea cvsInfo
        geometry <- liftIO $ makeCanvasGeometry cpn arr canvas
        let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord
        maybeFlip pagecoord (return Nothing) $
          \(pgn, PageCoord (x, y)) -> do
            nCvsInfo <-
              if cpn /= pgn
                then do
                  _ <- penPageSwitch pgn
                  -- temporary dirty fix
                  return (set currentPageNum (unPageNum pgn) cvsInfo)
                else return cvsInfo
            Just <$> action nCvsInfo pgn geometry (x, y) ctime
  
  -- | enter pen drawing mode
  penStart ::
    CanvasId ->
    PointerCoord ->
    MainCoroutine (Maybe (Maybe (Maybe ())))
  penStart cid pcoord = commonPenStart penAction cid pcoord
    where
      penAction ::
        forall b.
        CanvasInfo b ->
        PageNum ->
        CanvasGeometry ->
        (Double, Double) ->
        UTCTime ->
        MainCoroutine (Maybe (Maybe ()))
      penAction _cinfo pnum geometry (x, y) ctime = do
        xstate <- get
        let uhdl = view (unitHoodles . currentUnit) xstate
        let PointerCoord _ _ _ z = pcoord
        let currhdl = getHoodle uhdl
            pinfo = view penInfo xstate
            mpage = view (gpages . at (unPageNum pnum)) currhdl
        maybeFlip mpage (return Nothing) $ \_page -> do
          trdr <- createTempRender geometry (empty |> (x, y, z))
          mpdraw <- penProcess cid pnum geometry trdr ((x, y), z) ctime
          Cairo.surfaceFinish (tempSurfaceSrc trdr)
          Cairo.surfaceFinish (tempSurfaceTgt trdr)
          maybeFlip mpdraw (return (Just Nothing)) $ \pdraw ->
            case viewl pdraw of
              EmptyL -> return (Just (Just ()))
              (x1, _y1, _z1) :< _rest -> do
                if x1 <= 1e-3 -- this is ad hoc but..
                  then invalidateAll
                  else do
                    (newhdl, _bbox) <- addPDraw cid pinfo currhdl pnum pdraw
                    uhdl' <- liftIO (updatePageAll (ViewAppendState newhdl) uhdl)
                    commit (set (unitHoodles . currentUnit) uhdl' xstate)
                    return ()
                return (Just (Just ()))
  
  -- | main pen coordinate adding process
  -- | now being changed
  penProcess ::
    CanvasId ->
    PageNum ->
    CanvasGeometry ->
    TempRender (Seq (Double, Double, Double)) ->
    ((Double, Double), Double) ->
    UTCTime ->
    MainCoroutine (Maybe (Seq (Double, Double, Double)))
  penProcess cid pnum geometry trdr ((x0, y0), z0) ctime = do
    r <- nextevent
    ntime <- liftIO getCurrentTime
    let ispressandhold =
          abs (toRational (diffUTCTime ctime ntime)) > 1 % 2
        lst = (toList . tempInfo) trdr
        deltax =
          let xlst = map (\(x, _, _) -> x) lst
           in abs (maximum xlst - minimum xlst)
        deltay =
          let ylst = map (\(_, y, _) -> y) lst
           in abs (maximum ylst - minimum ylst)
    -- temporarily fix the range
    if deltax < 20 && deltay < 20 && ispressandhold && Prelude.length lst < 20
      then return Nothing
      else do
        xst <- get
        forBoth' unboxBiAct (fsingle r xst) . (getCanvasInfo cid . view (unitHoodles . currentUnit)) $ xst
    where
      pdraw = tempInfo trdr
      fsingle ::
        forall b.
        UserEvent ->
        HoodleState ->
        CanvasInfo b ->
        MainCoroutine (Maybe (Seq (Double, Double, Double)))
      fsingle r xstate cvsInfo =
        penMoveAndUpOnly
          r
          pnum
          geometry
          (penProcess cid pnum geometry trdr ((x0, y0), z0) ctime)
          ( \(pcoord, (x, y)) -> do
              let PointerCoord _ _ _ z = pcoord
              let pinfo = view penInfo xstate
              let xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum)
                  tmpstrk = createNewStroke pinfo pdraw
                  renderfunc = do
                    xformfunc
                    renderStrk tmpstrk
              let (srcsfc, tgtsfc) = (,) <$> tempSurfaceSrc <*> tempSurfaceTgt $ trdr
              virtualDoubleBufferDraw srcsfc tgtsfc (return ()) renderfunc
              liftIO $ doubleBufferFlush tgtsfc cvsInfo
              ---
              let ntrdr = trdr {tempInfo = pdraw |> (x, y, z)}
              penProcess cid pnum geometry ntrdr ((x, y), z) ctime
          )
          (\_ -> return (Just pdraw))
  
  -- |
  skipIfNotInSamePage ::
    Monad m =>
    PageNum ->
    CanvasGeometry ->
    PointerCoord ->
    m a ->
    ((PointerCoord, (Double, Double)) -> m a) ->
    m a
  skipIfNotInSamePage pgn geometry pcoord skipaction ordaction =
    switchActionEnteringDiffPage
      pgn
      geometry
      pcoord
      skipaction
      (\_ _ -> skipaction)
      (\_ (_, PageCoord xy) -> ordaction (pcoord, xy))
  
  -- |
  switchActionEnteringDiffPage ::
    Monad m =>
    PageNum ->
    CanvasGeometry ->
    PointerCoord ->
    m a ->
    (PageNum -> (PageNum, PageCoordinate) -> m a) ->
    (PageNum -> (PageNum, PageCoordinate) -> m a) ->
    m a
  switchActionEnteringDiffPage pgn geometry pcoord skipaction chgaction ordaction = do
    let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord
    maybeFlip pagecoord skipaction $
      \(cpn, pxy) ->
        if pgn == cpn
          then ordaction pgn (cpn, pxy)
          else chgaction pgn (cpn, pxy)
  
  -- | in page action
  penMoveAndUpOnly ::
    Monad m =>
    UserEvent ->
    PageNum ->
    CanvasGeometry ->
    m a ->
    ((PointerCoord, (Double, Double)) -> m a) ->
    (PointerCoord -> m a) ->
    m a
  penMoveAndUpOnly r pgn geometry defact moveaction upaction =
    case r of
      PenMove _ pcoord -> skipIfNotInSamePage pgn geometry pcoord defact moveaction
      PenUp _ pcoord -> upaction pcoord
      _ -> defact
  
  -- |
  penMoveAndUpInterPage ::
    Monad m =>
    UserEvent ->
    PageNum ->
    CanvasGeometry ->
    m a ->
    (PageNum -> (PageNum, PageCoordinate) -> m a) ->
    (PointerCoord -> m a) ->
    m a
  penMoveAndUpInterPage r pgn geometry defact moveaction upaction =
    case r of
      PenMove _ pcoord ->
        switchActionEnteringDiffPage pgn geometry pcoord defact moveaction moveaction
      PenUp _ pcoord -> upaction pcoord
      _ -> defact
  
  -- | process action when last time was before time diff limit, otherwise
  --   just do default action.
  processWithTimeInterval ::
    (Monad m, MonadIO m) =>
    -- | time diff
    NominalDiffTime ->
    -- | not larger than time diff bound
    (UTCTime -> m a) ->
    -- | larger than time diff bound
    (UTCTime -> m a) ->
    -- | last updated time
    UTCTime ->
    m a
  processWithTimeInterval tdiffbound defact updateact otime = do
    ctime <- liftIO getCurrentTime
    let dtime = diffUTCTime ctime otime
    if dtime > tdiffbound then updateact ctime else defact otime
  
  -- |
  processWithDefTimeInterval ::
    (Monad m, MonadIO m) =>
    -- | not larger than time diff bound
    (UTCTime -> m a) ->
    -- | larger than time diff bound
    (UTCTime -> m a) ->
    -- | last updated time
    UTCTime ->
    m a
  processWithDefTimeInterval = processWithTimeInterval dtimeBound
  