module Hoodle.Widget.PanZoom where
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
import Data.Hoodle.BBox
import Data.Hoodle.Simple
import Graphics.Hoodle.Render.Util.HitTest
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)
let otherwidgets = delete PanZoomWidget allWidgets
liftIO $ renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing)
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
xtrans = (1 z)*xo/zw
ytrans = (1 z)*yo/zh
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 ((dxw),(dyh))
manipulatePZW :: (PanZoomTouch,PanZoomMode)
-> CanvasId
-> CanvasGeometry
-> (Surface,Surface)
-> CanvasCoordinate
-> CanvasCoordinate
-> 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
where
again t = manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy t
moveact pcoord =
processWithDefTimeInterval
again
(\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+xdxd0,yorig+ydyd0))
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_dx0_d,y_dy0_d)
moveViewPortBy (return ()) cid
(\(xorig,yorig)->(xorigdx_d,yorigdy_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+xx0 < 50 = 50
| xw+xx0 > cw50 = cw50
| otherwise = xw+xx0
nposy | yw+yy0 < 50 = 50
| yw+yy0 > ch50 = ch50
| otherwise = yw+yy0
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+xx0 < 50 = 50
| xw+xx0 > cw50 = cw50
| otherwise = xw+xx0
nposy | yw+yy0 < 50 = 50
| yw+yy0 > ch50 = ch50
| otherwise = yw+yy0
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
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
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 ()