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

module Hoodle.Widget.PanZoom where

-- from other packages
import           Control.Category
import           Control.Lens (view,set)
import           Control.Monad.Identity 
import           Control.Monad.State 
import           Data.Time.Clock 
import           Graphics.Rendering.Cairo 
import           Graphics.UI.Gtk hiding (get,set) 
-- import           Graphics.UI.Gtk hiding (get,set)
-- import qualified Graphics.UI.Gtk as Gtk (get)
-- from hoodle-platform 
import           Data.Hoodle.BBox

import           Data.Hoodle.Simple



import           Graphics.Hoodle.Render.Util.HitTest
-- 
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.View.Coordinate
import           Hoodle.View.Draw
-- 
import Prelude hiding ((.),id)


data WidgetMode = Moving | Zooming | Panning Bool 

widgetCheckPen :: CanvasId -> PointerCoord 
               -> MainCoroutine () 
               -> MainCoroutine ()
widgetCheckPen cid pcoord act = do 
    xst <- get
    let cinfobox = getCanvasInfo cid xst 
    boxAction (f xst) cinfobox 
  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)
          zbbox = BBox (x0+30,y0+30) (x0+70,y0+70)
              
          
      if (isPointInBBox obbox (x,y))  
         then do 
           let mode | isPointInBBox zbbox (x,y) = Zooming 
                    | isPointInBBox pbbox1 (x,y) = Panning False
                    | isPointInBBox pbbox2 (x,y) = Panning True 
                    | otherwise = Moving 
           let hdl = getHoodle xst
           (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 do 
           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 --  if x0 > xo then x - x0 else x0 - x 
        ty = y - y0 -- if y0 > yo then y - y0 else y0 - y
        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 :: WidgetMode 
                     -> 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 :: WidgetMode -> 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) -- (xw+x-x0,yw+y-y0)
                  changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a 
                  changeact cinfo =  
                    set (canvasWidgets.testWidgetPosition) nwpos $ cinfo
                  ncinfobox = selectBox changeact changeact  cinfobox
              put (setCanvasInfo (cid,ncinfobox) xst)
              renderWith sfc2 $ do 
                setSourceSurface sfc 0 0 
                setOperator OperatorSource 
                paint
                setOperator OperatorOver
                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))
              renderWith sfc2 $ do 
                  save
                  scale z z
                  translate xtrans ytrans 
                  setSourceSurface sfc 0 0 
                  setOperator OperatorSource 
                  paint
                  setOperator OperatorOver
                  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
                  ncinfobox = selectBox changeact changeact  cinfobox
              put (setCanvasInfo (cid,ncinfobox) xst)
                  
              renderWith sfc2 $ do 
                  save
                  translate xtrans ytrans 
                  setSourceSurface sfc 0 0 
                  setOperator OperatorSource 
                  paint
                  setOperator OperatorOver
                  restore
                  renderPanZoomWidget Nothing nwpos 
          --   
          xst2 <- get 
          let cinfobox = getCanvasInfo cid xst2 
              drawact :: (ViewMode a) => CanvasInfo a -> IO ()
              drawact cinfo = do 
                let canvas = view drawArea cinfo 
                win <- widgetGetDrawWindow canvas
                renderWithDrawable win $ do 
                  setSourceSurface sfc2 0 0 
                  setOperator OperatorSource 
                  paint
          liftIO $ boxAction drawact cinfobox