-----------------------------------------------------------------------------
-- |
-- Module      : Hoodle.Widget.PanZoom
-- Copyright   : (c) 2013 Ian-Woo Kim
--
-- License     : BSD3
-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability   : experimental
-- Portability : GHC
--
-- Pan-Zoom widget drawing and action
-- 
-----------------------------------------------------------------------------

module Hoodle.Widget.PanZoom where

-- from other packages
import           Control.Lens (view,set,over)
import           Control.Monad.Identity 
import           Control.Monad.State 
import           Data.Time.Clock 
import           Graphics.Rendering.Cairo 
-- import           Graphics.UI.Gtk hiding (get,set) 
-- from hoodle-platform 
import           Data.Hoodle.BBox
import           Data.Hoodle.Simple
import           Graphics.Hoodle.Render.Util.HitTest
-- from this package 
import           Hoodle.Accessor
import           Hoodle.Coroutine.Draw
import           Hoodle.Coroutine.Page
import           Hoodle.Coroutine.Pen 
import           Hoodle.Coroutine.Scroll
import           Hoodle.Device
import           Hoodle.ModelAction.Page 
import           Hoodle.Type.Canvas
import           Hoodle.Type.Coroutine
import           Hoodle.Type.Event
import           Hoodle.Type.HoodleState 
import           Hoodle.Type.PageArrangement 
import           Hoodle.Type.Widget
import           Hoodle.View.Coordinate
import           Hoodle.View.Draw
-- 

data PanZoomMode = Moving | Zooming | Panning Bool

widgetCheckPen :: CanvasId -> PointerCoord 
               -> MainCoroutine () 
               -> MainCoroutine ()
widgetCheckPen cid pcoord act = do 
    xst <- get
    let cinfobox = getCanvasInfo cid xst 
        b = view (unboxLens (canvasWidgets.widgetConfig.doesUsePanZoom)) cinfobox
    if b then boxAction (f xst) cinfobox else act 
  where 
    f xst cinfo = do 
      let cvs = view drawArea cinfo
          pnum = (PageNum . view currentPageNum) cinfo 
          arr = view (viewInfo.pageArrangement) cinfo
      geometry <- liftIO $ makeCanvasGeometry pnum arr cvs 
      let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord
      let owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.testWidgetPosition) cinfo
          obbox = BBox (x0,y0) (x0+100,y0+100) 
          pbbox1 = BBox (x0+10,y0+10) (x0+50,y0+90)
          pbbox2 = BBox (x0+50,y0+10) (x0+90,y0+90)
          pbbox3 = BBox (x0+90,y0) (x0+100,y0+10)
          zbbox = BBox (x0+30,y0+30) (x0+70,y0+70)
      if (isPointInBBox obbox (x,y))  
         then do 
           let mmode | isPointInBBox zbbox (x,y) = Just Zooming 
                     | isPointInBBox pbbox1 (x,y) = Just (Panning False)
                     | isPointInBBox pbbox2 (x,y) = Just (Panning True)
                     | isPointInBBox pbbox3 (x,y) = Nothing
                     | otherwise = Just Moving 
           let hdl = getHoodle xst
           case mmode of 
             Nothing -> togglePanZoom
             Just mode -> do 
               (sfc,Dim wsfc hsfc) <- case mode of 
                                        Moving -> liftIO (canvasImageSurface Nothing geometry hdl)
                                        Zooming -> liftIO (canvasImageSurface (Just 1) geometry hdl)
                                        Panning _ -> liftIO (canvasImageSurface (Just 1) geometry hdl) 
               sfc2 <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)
               ctime <- liftIO getCurrentTime 
               startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime 
               liftIO $ surfaceFinish sfc 
               liftIO $ surfaceFinish sfc2
         else act 

-- | 
findZoomXform :: Dimension 
               -> ((Double,Double),(Double,Double),(Double,Double)) 
               -> (Double,(Double,Double))
findZoomXform (Dim w h) ((xo,yo),(x0,y0),(x,y)) = 
    let tx = x - x0 
        ty = y - y0 
        ztx = 1 + tx / 200
        zty = 1 + ty / 200
        zx | ztx > 2 = 2  
           | ztx < 0.5 = 0.5
           | otherwise = ztx
        zy | zty > 2 = 2  
           | zty < 0.5 = 0.5
           | otherwise = zty                                          
        z | zx >= 1 && zy >= 1 = max zx zy
          | zx < 1 && zy < 1 = min zx zy 
          | otherwise = zx
        xtrans = (1 -z)*xo/z-w
        ytrans = (1- z)*yo/z-h 
    in (z,(xtrans,ytrans))

-- |
findPanXform :: Dimension 
             -> ((Double,Double),(Double,Double)) 
             -> (Double,Double)
findPanXform (Dim w h) ((x0,y0),(x,y)) = 
    let tx = x - x0 
        ty = y - y0 
        dx | tx > w = w 
           | tx < (-w) = -w 
           | otherwise = tx 
        dy | ty > h = h 
           | ty < (-h) = -h 
           | otherwise = ty 
    in ((dx-w),(dy-h))

-- | 
startWidgetAction :: PanZoomMode 
                     -> CanvasId 
                     -> CanvasGeometry 
                     -> (Surface,Surface)
                     -> CanvasCoordinate -- ^ original widget position
                     -> CanvasCoordinate -- ^ where pen pressed 
                     -> UTCTime
                     -> MainCoroutine ()
startWidgetAction mode cid geometry (sfc,sfc2)
                  owxy@(CvsCoord (xw,yw)) oxy@(CvsCoord (x0,y0)) otime = do
  r <- nextevent
  case r of 
    PenMove _ pcoord -> do 
      processWithDefTimeInterval
        (startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy) 
        (\ctime -> movingRender mode cid geometry (sfc,sfc2) owxy oxy pcoord 
                   >> startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime)
        otime 
    PenUp _ pcoord -> do 
      case mode of 
        Zooming -> do 
          let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord 
              CanvasDimension cdim = canvasDim geometry 
              ccoord@(CvsCoord (xo,yo)) = CvsCoord (xw+50,yw+50)
              (z,(_,_)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))
              nratio = zoomRatioFrmRelToCurr geometry z
              mpnpgxy = (desktop2Page geometry . canvas2Desktop geometry) ccoord 
          canvasZoomUpdateGenRenderCvsId (return ()) cid (Just (Zoom nratio)) Nothing 
          case mpnpgxy of 
            Nothing -> return () 
            Just pnpgxy -> do 
              xstate <- get
              geom' <- liftIO $ getCanvasGeometryCvsId cid xstate
              let DeskCoord (xd,yd) = page2Desktop geom' pnpgxy
                  DeskCoord (xd0,yd0) = canvas2Desktop geom' ccoord 
              moveViewPortBy (return ()) cid 
                (\(xorig,yorig)->(xorig+xd-xd0,yorig+yd-yd0)) 
        Panning _ -> do 
          let (x_d,y_d) = (unDeskCoord . device2Desktop geometry) pcoord  
              (x0_d,y0_d) = (unDeskCoord . canvas2Desktop geometry) 
                              (CvsCoord (x0,y0))
              (dx_d,dy_d) = (x_d-x0_d,y_d-y0_d)
          moveViewPortBy (return ()) cid 
            (\(xorig,yorig)->(xorig-dx_d,yorig-dy_d))                 
        _ -> return ()
      invalidate cid 
    _ -> startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy otime

-- | 
movingRender :: PanZoomMode -> CanvasId -> CanvasGeometry -> (Surface,Surface) 
                -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord 
                -> MainCoroutine () 
movingRender mode cid geometry (sfc,sfc2) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do 
          let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord 
          xst <- get 
          case mode of
            Moving -> do 
              let CanvasDimension (Dim cw ch) = canvasDim geometry 
                  cinfobox = getCanvasInfo cid xst 
                  nposx | xw+x-x0 < -50 = -50 
                        | xw+x-x0 > cw-50 = cw-50 
                        | otherwise = xw+x-x0
                  nposy | yw+y-y0 < -50 = -50 
                        | yw+y-y0 > ch-50 = ch-50 
                        | otherwise = yw+y-y0                             
                  nwpos = CvsCoord (nposx,nposy) 
                  changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a 
                  changeact cinfo =  
                    set (canvasWidgets.testWidgetPosition) nwpos $ cinfo
                  ncinfobox = selectBox changeact changeact  cinfobox
              put (setCanvasInfo (cid,ncinfobox) xst)
              virtualDoubleBufferDraw sfc sfc2 (return ()) (renderPanZoomWidget Nothing nwpos)
            Zooming -> do 
              let cinfobox = getCanvasInfo cid xst               
              let pos = runIdentity (boxAction (return . view (canvasWidgets.testWidgetPosition)) cinfobox )
              let (xo,yo) = (xw+50,yw+50)
                  CanvasDimension cdim = canvasDim geometry 
                  (z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))
              virtualDoubleBufferDraw sfc sfc2 
                (save >> scale z z >> translate xtrans ytrans)
                (restore >> renderPanZoomWidget Nothing pos)
            Panning b -> do 
              let cinfobox = getCanvasInfo cid xst               
                  CanvasDimension cdim = canvasDim geometry 
                  (xtrans,ytrans) = findPanXform cdim ((x0,y0),(x,y))
              let CanvasDimension (Dim cw ch) = canvasDim geometry 
                  nposx | xw+x-x0 < -50 = -50 
                        | xw+x-x0 > cw-50 = cw-50 
                        | otherwise = xw+x-x0
                  nposy | yw+y-y0 < -50 = -50 
                        | yw+y-y0 > ch-50 = ch-50 
                        | otherwise = yw+y-y0                             
                  nwpos = if b 
                          then CvsCoord (nposx,nposy) 
                          else 
                            runIdentity (boxAction (return . view (canvasWidgets.testWidgetPosition)) cinfobox)
                  -- changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a 
                  -- changeact cinfo =  
                  --   set (canvasWidgets.testWidgetPosition) nwpos $ cinfo
                  --             selectBox changeact changeact  cinfobox
                  ncinfobox = set (unboxLens (canvasWidgets.testWidgetPosition)) nwpos cinfobox
              put (setCanvasInfo (cid,ncinfobox) xst)
              virtualDoubleBufferDraw sfc sfc2 
                (save >> translate xtrans ytrans) 
                (restore >> renderPanZoomWidget Nothing nwpos)
          --   
          xst2 <- get 
          let cinfobox = getCanvasInfo cid xst2 
          liftIO $ boxAction (doubleBufferFlush sfc2) cinfobox

  
-- | 
togglePanZoom :: MainCoroutine () 
togglePanZoom = do 
  modify (over (currentCanvasInfo . unboxLens (canvasWidgets.widgetConfig.doesUsePanZoom)) not)
  invalidateAll