module Hoodle.Coroutine.Page where
import Control.Lens (view,set,over)
import Control.Monad
import Control.Monad.State
import qualified Data.IntMap as M
import Data.Hoodle.Generic
import Data.Hoodle.Select
import Graphics.Hoodle.Render.Type.Background
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
import Hoodle.View.Draw
changePage :: (Int -> Int) -> MainCoroutine ()
changePage modifyfn = updateXState changePageAction
>> adjustScrollbarWithGeometryCurrent
>> invalidateAllInBBox Nothing Efficient
where changePageAction xst = selectBoxAction (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
-> 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 (totnumpages1) 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 =
selectBoxAction (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
boxAction fsingle . view currentCanvasInfo =<< get
where
fsingle :: (ViewMode a) => 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 = boxAction (fsimple xst) . view currentCanvasInfo $ xst
fsimple :: (ViewMode a) => 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
deleteCurrentPage :: MainCoroutine ()
deleteCurrentPage = do
updateXState delpgact >> commit_ >> canvasZoomUpdateAll >> invalidateAll
where
delpgact xst = boxAction (fsimple xst) . view currentCanvasInfo $ xst
fsimple :: (ViewMode a) => 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
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