module Hoodle.Coroutine.Mode where
import Control.Applicative
import Control.Lens (view,set,(.~))
import Control.Monad.State
import qualified Data.IntMap as M
import qualified Graphics.UI.Gtk as Gtk (adjustmentGetValue)
import Data.Hoodle.BBox
import Data.Hoodle.Generic
import Data.Hoodle.Select
import Graphics.Hoodle.Render
import Graphics.Hoodle.Render.Type
import Hoodle.Accessor
import Hoodle.Coroutine.Draw
import Hoodle.Coroutine.Scroll
import Hoodle.GUI.Reflect
import Hoodle.Type.Alias
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.View.Coordinate
import Prelude hiding (mapM_, mapM)
modeChange :: UserEvent -> MainCoroutine ()
modeChange command = do
case command of
ToViewAppendMode -> updateXState select2edit >> invalidateAll
ToSelectMode -> updateXState edit2select >> invalidateAllInBBox Nothing Efficient
_ -> return ()
reflectPenModeUI
reflectPenColorUI
reflectPenWidthUI
where select2edit xst =
either (noaction xst) (whenselect xst) . hoodleModeStateEither
. view (unitHoodles.currentUnit.hoodleModeState) $ xst
edit2select xst =
either (whenedit xst) (noaction xst) . hoodleModeStateEither
. view (unitHoodles.currentUnit.hoodleModeState) $ xst
noaction :: HoodleState -> a -> MainCoroutine HoodleState
noaction xst = const (return xst)
whenselect :: HoodleState -> Hoodle SelectMode -> MainCoroutine HoodleState
whenselect xst thdl = do
let pages = view gselAll thdl
mselect = view gselSelected thdl
cid = getCurrentCanvasId (view (unitHoodles.currentUnit) xst)
npages <- maybe (return pages)
(\(spgn,spage) -> do
let npage = hPage2RPage spage
callRenderer_ $ updatePageBuf cid npage
return $ M.adjust (const npage) spgn pages )
mselect
let nthdl = set gselAll npages . set gselSelected Nothing $ thdl
return $ (unitHoodles.currentUnit.hoodleModeState .~ ViewAppendState (gSelect2GHoodle nthdl)) xst
whenedit :: HoodleState -> Hoodle EditMode -> MainCoroutine HoodleState
whenedit xst hdl =
return $ (unitHoodles.currentUnit.hoodleModeState .~ SelectState (gHoodle2GSelect hdl)) xst
viewModeChange :: UserEvent -> MainCoroutine ()
viewModeChange command = do
case command of
ToSinglePage -> updateUhdl cont2single >> invalidateAll
ToContSinglePage -> updateUhdl single2cont >> invalidateAll
_ -> return ()
adjustScrollbarWithGeometryCurrent
where cont2single :: UnitHoodle -> MainCoroutine UnitHoodle
cont2single uhdl = unboxBiAct (const (return uhdl)) (cont2SingPage uhdl) . view currentCanvasInfo $ uhdl
single2cont :: UnitHoodle -> MainCoroutine UnitHoodle
single2cont uhdl = unboxBiAct (sing2ContPage uhdl) (const (return uhdl)) . view currentCanvasInfo $ uhdl
cont2SingPage :: UnitHoodle -> CanvasInfo a -> MainCoroutine UnitHoodle
cont2SingPage uhdl cinfo = do
geometry <- liftIO $ getGeometry4CurrCvs uhdl
cdim <- liftIO $ return . canvasDim $ geometry
page <- getCurrentPageCurr
let zmode = view (viewInfo.zoomMode) cinfo
canvas = view drawArea cinfo
cpn = PageNum . view currentPageNum $ cinfo
pdim = PageDimension (view gdimension page)
ViewPortBBox bbox = view (viewInfo.pageArrangement.viewPortBBox) cinfo
(x0,y0) = bbox_upperleft bbox
(xpos,ypos) = maybe (0,0) (unPageCoord.snd) $ desktop2Page geometry (DeskCoord (x0,y0))
let arr = makeSingleArrangement zmode pdim cdim (xpos,ypos)
let nvinfo = ViewInfo (view zoomMode (view viewInfo cinfo)) arr
ncinfo = CanvasInfo (view canvasId cinfo)
canvas
(view mDrawSurface cinfo)
(view scrolledWindow cinfo)
nvinfo
(unPageNum cpn)
(view horizAdjustment cinfo)
(view vertAdjustment cinfo)
(view horizAdjConnId cinfo)
(view vertAdjConnId cinfo)
(view canvasWidgets cinfo)
(view notifiedItem cinfo)
return $ (currentCanvasInfo .~ CanvasSinglePage ncinfo) uhdl
sing2ContPage :: UnitHoodle -> CanvasInfo a -> MainCoroutine UnitHoodle
sing2ContPage uhdl cinfo = do
cdim <- liftIO $ return . canvasDim =<< getGeometry4CurrCvs uhdl
let zmode = view (viewInfo.zoomMode) cinfo
canvas = view drawArea cinfo
cpn = PageNum . view currentPageNum $ cinfo
(hadj,vadj) = view adjustments cinfo
(xpos,ypos) <- liftIO $ (,) <$> Gtk.adjustmentGetValue hadj <*> Gtk.adjustmentGetValue vadj
let arr = makeContinuousArrangement zmode cdim (getHoodle uhdl)
(cpn, PageCoord (xpos,ypos))
geometry <- liftIO $ makeCanvasGeometry cpn arr canvas
let DeskCoord (nxpos,nypos) = page2Desktop geometry (cpn,PageCoord (xpos,ypos))
let vinfo = view viewInfo cinfo
nvinfo = ViewInfo (view zoomMode vinfo) arr
ncinfotemp = CanvasInfo (view canvasId cinfo)
(view drawArea cinfo)
(view mDrawSurface cinfo)
(view scrolledWindow cinfo)
nvinfo
(view currentPageNum cinfo)
hadj
vadj
(view horizAdjConnId cinfo)
(view vertAdjConnId cinfo)
(view canvasWidgets cinfo)
(view notifiedItem cinfo)
ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (nxpos,nypos))
ncinfo = (currentPageNum .~ unPageNum ncpn) ncinfotemp
return $ (currentCanvasInfo .~ CanvasContPage ncinfo) uhdl