----------------------------------------------------------------------------- -- | -- Module : Hoodle.Widget.PanZoom -- Copyright : (c) 2013 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim -- 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.List (delete) import Data.Time.Clock import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (get,set) import System.Process -- 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.File 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.Enum 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 data PanZoomTouch = TouchMode | PenMode deriving (Show,Eq,Ord) checkPointerInPanZoom :: (ViewMode a) => (CanvasId,CanvasInfo a,CanvasGeometry) -> PointerCoord -> Maybe (Maybe (PanZoomMode,(CanvasCoordinate,CanvasCoordinate))) checkPointerInPanZoom (cid,cinfo,geometry) pcoord | b = let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) 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,y0) (x0+10,y0+10) zbbox = BBox (x0+30,y0+30) (x0+70,y0+70) in if (isPointInBBox obbox (x,y)) then let mmode | isPointInBBox zbbox (x,y) = Just (Zooming,(oxy,owxy)) | isPointInBBox pbbox1 (x,y) = Just (Panning False,(oxy,owxy)) | isPointInBBox pbbox2 (x,y) = Just (Panning True,(oxy,owxy)) | isPointInBBox pbbox3 (x,y) = Nothing | otherwise = Just (Moving,(oxy,owxy)) in (Just mmode) else Nothing | otherwise = Nothing where b = view (canvasWidgets.widgetConfig.doesUsePanZoomWidget) cinfo -- | startPanZoomWidget :: (ViewMode a) => PanZoomTouch -> (CanvasId,CanvasInfo a,CanvasGeometry) -> Maybe (PanZoomMode,(CanvasCoordinate,CanvasCoordinate)) -> MainCoroutine () startPanZoomWidget tchmode (cid,cinfo,geometry) mmode = do xst <- get let hdl = getHoodle xst case mmode of Nothing -> togglePanZoom cid Just (mode,(oxy,owxy)) -> do (srcsfc,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) -- need to draw other widgets here let otherwidgets = delete PanZoomWidget allWidgets liftIO $ renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) -- end : need to draw other widgets here ^^^ tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc) ctime <- liftIO getCurrentTime manipulatePZW (tchmode,mode) cid geometry (srcsfc,tgtsfc) owxy oxy ctime liftIO $ surfaceFinish srcsfc liftIO $ surfaceFinish tgtsfc -- | 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 -} -- simplified z = 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)) -- | manipulate Pan-Zoom widget until released when grabbing the widget manipulatePZW :: (PanZoomTouch,PanZoomMode) -> CanvasId -> CanvasGeometry -> (Surface,Surface) -- ^ (Source Surface, Target Surface) -> CanvasCoordinate -- ^ original widget position -> CanvasCoordinate -- ^ where pen pressed -> UTCTime -> MainCoroutine () manipulatePZW fullmode@(tchmode,mode) cid geometry (srcsfc,tgtsfc) owxy@(CvsCoord (xw,yw)) oxy@(CvsCoord (x0,y0)) otime = do r <- nextevent case r of PenMove _ pcoord -> if (tchmode /= PenMode) then again otime else moveact pcoord TouchMove _ pcoord -> if (tchmode /= TouchMode) then again otime else do b <- liftM (view (settings.doesUseTouch)) get when b $ moveact pcoord PenUp _ pcoord -> if (tchmode /= PenMode) then again otime else upact pcoord TouchUp _ pcoord -> if (tchmode /= TouchMode) then again otime else do b <- liftM (view (settings.doesUseTouch)) get when b $ upact pcoord _ -> again otime -- manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy otime where again t = manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy t moveact pcoord = processWithDefTimeInterval again -- (manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy) (\ctime -> movingRender mode cid geometry (srcsfc,tgtsfc) owxy oxy pcoord >> manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy ctime) otime upact 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 -- | movingRender :: PanZoomMode -> CanvasId -> CanvasGeometry -> (Surface,Surface) -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord -> MainCoroutine () movingRender mode cid geometry (srcsfc,tgtsfc) (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.panZoomWidgetConfig.panZoomWidgetPosition) nwpos $ cinfo ncinfobox = selectBox changeact changeact cinfobox isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox put (setCanvasInfo (cid,ncinfobox) xst) virtualDoubleBufferDraw srcsfc tgtsfc (return ()) (renderPanZoomWidget isTouchZoom Nothing nwpos) Zooming -> do let cinfobox = getCanvasInfo cid xst let pos = runIdentity (boxAction (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox) let (xo,yo) = (xw+50,yw+50) CanvasDimension cdim = canvasDim geometry (z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y)) isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox virtualDoubleBufferDraw srcsfc tgtsfc (save >> scale z z >> translate xtrans ytrans) (restore >> renderPanZoomWidget isTouchZoom 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.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox) ncinfobox = set (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) nwpos cinfobox isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox put (setCanvasInfo (cid,ncinfobox) xst) virtualDoubleBufferDraw srcsfc tgtsfc (save >> translate xtrans ytrans) (restore >> renderPanZoomWidget isTouchZoom Nothing nwpos) -- xst2 <- get let cinfobox = getCanvasInfo cid xst2 liftIO $ boxAction (doubleBufferFlush tgtsfc) cinfobox -- | togglePanZoom :: CanvasId -> MainCoroutine () togglePanZoom cid = do modify $ \xst -> let cinfobox = getCanvasInfo cid xst ncinfobox = over (unboxLens (canvasWidgets.widgetConfig.doesUsePanZoomWidget)) not cinfobox in setCanvasInfo (cid,ncinfobox) xst invalidateInBBox Nothing Efficient cid -- | touchStart :: CanvasId -> PointerCoord -> MainCoroutine () touchStart cid pcoord = boxAction chk =<< liftM (getCanvasInfo cid) get where chk :: (ViewMode a) => CanvasInfo a -> MainCoroutine () chk cinfo = do let cvs = view drawArea cinfo pnum = (PageNum . view currentPageNum) cinfo arr = view (viewInfo.pageArrangement) cinfo geometry <- liftIO $ makeCanvasGeometry pnum arr cvs let triplet = (cid,cinfo,geometry) oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo obbox = BBox (x0,y0) (x0+100,y0+100) xst <- get if (isPointInBBox obbox (x,y)) then do let changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a changeact = over (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) not ncinfobox = selectBox changeact changeact . getCanvasInfo cid $ xst put (setCanvasInfo (cid,ncinfobox) xst) invalidateInBBox Nothing Efficient cid else do let b = view (settings.doesUseTouch) xst isZoomTouch = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) cinfo if b then if isZoomTouch then startPanZoomWidget TouchMode triplet (Just (Zooming,(oxy,oxy))) else startPanZoomWidget TouchMode triplet (Just (Panning False,(oxy,oxy))) else do let devlst = view deviceList xst doIOaction $ \_ -> do setToggleUIForFlag "HANDA" (settings.doesUseTouch) xst -- ad hoc let touchstr = dev_touch_str devlst when (touchstr /= "touch") $ do readProcess "xinput" [ "disable", dev_touch_str devlst ] "" return () -- return (UsrEv ActionOrdered) waitSomeEvent (\e -> case e of TouchUp _ _ -> True ; _ -> False) >> return () toggleTouch :: MainCoroutine () toggleTouch = do updateFlagFromToggleUI "HANDA" (settings.doesUseTouch) xst <- get let devlst = view deviceList xst let b = view (settings.doesUseTouch) xst when b $ do -- ad hoc let touchstr = dev_touch_str devlst when (touchstr /= "touch") $ do liftIO $ readProcess "xinput" [ "enable", dev_touch_str devlst ] "" return () -- let (cid,cinfobox) = view currentCanvas xst put (set (currentCanvasInfo. unboxLens (canvasWidgets.widgetConfig.doesUsePanZoomWidget)) True xst) invalidateInBBox Nothing Efficient cid return ()