module Hoodle.Widget.PanZoom where
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 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
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/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))
startWidgetAction :: WidgetMode
-> CanvasId
-> CanvasGeometry
-> (Surface,Surface)
-> CanvasCoordinate
-> CanvasCoordinate
-> 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+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
_ -> 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+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.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+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.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