hoodle-core-0.13: src/Hoodle/Coroutine/Page.hs
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Page
-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Hoodle.Coroutine.Page where
import Control.Lens (view,set,over)
import Control.Monad
import Control.Monad.State
import qualified Data.IntMap as M
-- from hoodle-platform
import Data.Hoodle.Generic
import Data.Hoodle.Select
import Graphics.Hoodle.Render.Type.Background
-- from this package
import Hoodle.Accessor
import Hoodle.Coroutine.Draw
import Hoodle.Coroutine.Commit
import Hoodle.Coroutine.Scroll
import Hoodle.ModelAction.Page
import Hoodle.Type.Alias
import Hoodle.Type.Coroutine
import Hoodle.Type.Canvas
import Hoodle.Type.PageArrangement
import Hoodle.Type.HoodleState
import Hoodle.Type.Enum
import Hoodle.Util
import Hoodle.View.Coordinate
--
-- | change page of current canvas using a modify function
changePage :: (Int -> Int) -> MainCoroutine ()
changePage modifyfn = updateXState changePageAction
>> adjustScrollbarWithGeometryCurrent
>> invalidateAllInBBox Nothing Efficient
where changePageAction xst = unboxBiAct (fsingle xst) (fcont xst)
. view currentCanvasInfo $ xst
fsingle xstate cvsInfo = do
let xojst = view hoodleModeState $ xstate
npgnum = modifyfn (view currentPageNum cvsInfo)
cid = view canvasId cvsInfo
bsty = view backgroundStyle xstate
(b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState bsty npgnum xojst
xstate' <- liftIO $ updatePageAll xojst' xstate
ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid
xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate'
when b (commit xstatefinal)
return xstatefinal
fcont xstate cvsInfo = do
let xojst = view hoodleModeState xstate
npgnum = modifyfn (view currentPageNum cvsInfo)
cid = view canvasId cvsInfo
bsty = view backgroundStyle xstate
(b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState bsty npgnum xojst
xstate' <- liftIO $ updatePageAll xojst' xstate
ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid
xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate'
when b (commit xstatefinal)
return xstatefinal
-- |
changePageInHoodleModeState :: BackgroundStyle
-> Int -- ^ new page number
-> HoodleModeState
-> (Bool,Int,Page EditMode,HoodleModeState)
changePageInHoodleModeState bsty npgnum hdlmodst =
let ehdl = hoodleModeStateEither hdlmodst
pgs = either (view gpages) (view gselAll) ehdl
totnumpages = M.size pgs
lpage = maybeError' "changePage" (M.lookup (totnumpages-1) pgs)
(isChanged,npgnum',npage',ehdl')
| npgnum >= totnumpages =
let cbkg = view gbackground lpage
nbkg
| isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty }
| otherwise = cbkg
npage = set gbackground nbkg
. newSinglePageFromOld $ lpage
npages = M.insert totnumpages npage pgs
in (True,totnumpages,npage,
either (Left . set gpages npages) (Right. set gselAll npages) ehdl )
| otherwise = let npg = if npgnum < 0 then 0 else npgnum
pg = maybeError' "changePage" (M.lookup npg pgs)
in (False,npg,pg,ehdl)
in (isChanged,npgnum',npage',either ViewAppendState SelectState ehdl')
-- |
canvasZoomUpdateGenRenderCvsId :: MainCoroutine ()
-> CanvasId
-> Maybe ZoomMode
-> Maybe (PageNum,PageCoordinate)
-> MainCoroutine ()
canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode mcoord
= updateXState zoomUpdateAction
>> adjustScrollbarWithGeometryCvsId cid
>> renderfunc
where zoomUpdateAction xst =
unboxBiAct (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst
fsingle xstate cinfo = do
geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo
page <- getCurrentPageCvsId cid
let zmode = maybe (view (viewInfo.zoomMode) cinfo) id mzmode
pdim = PageDimension $ view gdimension page
xy = either (const (0,0)) (unPageCoord.snd)
(getCvsOriginInPage geometry)
cdim = canvasDim geometry
narr = makeSingleArrangement zmode pdim cdim xy
ncinfobox = CanvasSinglePage
. set (viewInfo.pageArrangement) narr
. set (viewInfo.zoomMode) zmode $ cinfo
return . modifyCanvasInfo cid (const ncinfobox) $ xstate
fcont xstate cinfo = do
geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo
let zmode = maybe (view (viewInfo.zoomMode) cinfo) id mzmode
cpn = PageNum $ view currentPageNum cinfo
cdim = canvasDim geometry
hdl = getHoodle xstate
origcoord = case mcoord of
Just coord -> coord
Nothing -> either (const (cpn,PageCoord (0,0))) id
(getCvsOriginInPage geometry)
narr = makeContinuousArrangement zmode cdim hdl origcoord
ncinfobox = CanvasContPage
. set (viewInfo.pageArrangement) narr
. set (viewInfo.zoomMode) zmode $ cinfo
return . modifyCanvasInfo cid (const ncinfobox) $ xstate
-- |
canvasZoomUpdateCvsId :: CanvasId
-> Maybe ZoomMode
-> MainCoroutine ()
canvasZoomUpdateCvsId cid mzmode =
canvasZoomUpdateGenRenderCvsId invalidateAll cid mzmode Nothing
-- |
canvasZoomUpdateBufAll :: MainCoroutine ()
canvasZoomUpdateBufAll = do
klst <- liftM (M.keys . getCanvasInfoMap) get
mapM_ updatefunc klst
where
updatefunc cid
= canvasZoomUpdateGenRenderCvsId (invalidateInBBox Nothing Efficient cid) cid Nothing Nothing
-- |
canvasZoomUpdateAll :: MainCoroutine ()
canvasZoomUpdateAll = do
klst <- liftM (M.keys . getCanvasInfoMap) get
mapM_ (flip canvasZoomUpdateCvsId Nothing) klst
-- |
canvasZoomUpdate :: Maybe ZoomMode -> MainCoroutine ()
canvasZoomUpdate mzmode = do
cid <- (liftM (getCurrentCanvasId) get)
canvasZoomUpdateCvsId cid mzmode
-- |
pageZoomChange :: ZoomMode -> MainCoroutine ()
pageZoomChange = canvasZoomUpdate . Just
-- |
pageZoomChangeRel :: ZoomModeRel -> MainCoroutine ()
pageZoomChangeRel rzmode = do
forBoth' unboxBiAct fsingle . view currentCanvasInfo =<< get
where
fsingle :: CanvasInfo a -> MainCoroutine ()
fsingle cinfo = do
let cpn = PageNum (view currentPageNum cinfo)
arr = view (viewInfo.pageArrangement) cinfo
canvas = view drawArea cinfo
geometry <- liftIO $ makeCanvasGeometry cpn arr canvas
let nratio = relZoomRatio geometry rzmode
pageZoomChange (Zoom nratio)
-- |
newPage :: AddDirection -> MainCoroutine ()
newPage dir = updateXState npgBfrAct
>> commit_
>> canvasZoomUpdateAll
>> invalidateAll
where
npgBfrAct xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst
fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState
fsimple xstate cinfo = do
case view hoodleModeState xstate of
ViewAppendState hdl -> do
let bsty = view backgroundStyle xstate
hdl' = addNewPageInHoodle bsty dir hdl (view currentPageNum cinfo)
return =<< liftIO . updatePageAll (ViewAppendState hdl')
. set hoodleModeState (ViewAppendState hdl') $ xstate
SelectState _ -> do
liftIO $ putStrLn " not implemented yet"
return xstate
-- | delete current page of current canvas
deleteCurrentPage :: MainCoroutine ()
deleteCurrentPage = do
updateXState delpgact >> commit_ >> canvasZoomUpdateAll >> invalidateAll
where
delpgact xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst
fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState
fsimple xstate cinfo = do
case view hoodleModeState xstate of
ViewAppendState hdl -> do
hdl' <- liftIO $ deletePageInHoodle hdl
(PageNum (view currentPageNum cinfo))
return =<< liftIO . updatePageAll (ViewAppendState hdl')
. set hoodleModeState (ViewAppendState hdl') $ xstate
SelectState _ -> do
liftIO $ putStrLn " not implemented yet"
return xstate
-- | delete designated page
deletePageInHoodle :: Hoodle EditMode -> PageNum -> IO (Hoodle EditMode)
deletePageInHoodle hdl (PageNum pgn) = do
let pagelst = M.elems . view gpages $ hdl
(pagesbefore,_cpage:pagesafter) = splitAt pgn pagelst
npagelst = pagesbefore ++ pagesafter
nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl
return nhdl