hoodle-core-0.15: src/Hoodle/Coroutine/Page.hs
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Page
-- Copyright : (c) 2011-2015 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Hoodle.Coroutine.Page where
import Control.Applicative
import Control.Concurrent.STM
import Control.Lens (view,set,(.~), (^.))
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans.Reader (ask)
import qualified Data.Foldable as F
import Data.Function (on)
import qualified Data.IntMap as M
import Data.List (sortBy)
-- from hoodle-platform
import Data.Hoodle.Generic
import Data.Hoodle.Select
import Data.Hoodle.Simple (Dimension(..))
import Data.Hoodle.Zipper
import Graphics.Hoodle.Render.Type
-- 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 = (view backgroundStyle <$> get) >>= \bsty ->
updateUhdl (changePageAction bsty) >>
adjustScrollbarWithGeometryCurrent >>
invalidateAllInBBox Nothing Efficient
where changePageAction bsty uhdl = unboxBiAct (fsingle bsty uhdl) (fcont bsty uhdl)
. (^. currentCanvasInfo) $ uhdl
fsingle bsty uhdl cvsInfo = do
let xojst = view hoodleModeState $ uhdl
npgnum = modifyfn (cvsInfo ^. currentPageNum)
cid = view canvasId cvsInfo
(b,npgnum',_,xojst') <- changePageInHoodleModeState bsty npgnum xojst
uhdl' <- liftIO $ updatePageAll xojst' uhdl
ncvsInfo <- liftIO $ setPage uhdl' (PageNum npgnum') cid
let uhdlfinal = (currentCanvasInfo .~ ncvsInfo) uhdl'
when b $ updateUhdl (const (return uhdlfinal)) >> commit_
return uhdlfinal
fcont bsty uhdl cvsInfo = do
let xojst = view hoodleModeState uhdl
npgnum = modifyfn (cvsInfo ^. currentPageNum)
cid = cvsInfo ^. canvasId
(b,npgnum',_,xojst') <- changePageInHoodleModeState bsty npgnum xojst
uhdl' <- liftIO $ updatePageAll xojst' uhdl
ncvsInfo <- liftIO $ setPage uhdl' (PageNum npgnum') cid
let uhdlfinal = (currentCanvasInfo .~ ncvsInfo) uhdl'
when b $ updateUhdl (const (return uhdlfinal)) >> commit_
return uhdlfinal
-- |
changePageInHoodleModeState :: BackgroundStyle
-> Int -- ^ new page number
-> HoodleModeState
-> MainCoroutine (Bool,Int,Page EditMode,HoodleModeState)
changePageInHoodleModeState bsty npgnum hdlmodst = do
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') <-
if (npgnum >= totnumpages)
then do
let cbkg = view gbackground lpage
nbkg <- newBkg bsty cbkg
npage <- set gbackground nbkg <$> (newPageFromOld lpage)
geometry <- liftIO . getGeometry4CurrCvs . view (unitHoodles.currentUnit) =<< get
callRenderer_ $ updatePageCache geometry (PageNum (totnumpages-1),npage)
let npages = M.insert totnumpages npage pgs
return (True,totnumpages,npage,
either (Left . set gpages npages) (Right. set gselAll npages) ehdl )
else do
let npg = if npgnum < 0 then 0 else npgnum
pg = maybeError' "changePage" (M.lookup npg pgs)
return (False,npg,pg,ehdl)
return (isChanged,npgnum',npage',either ViewAppendState SelectState ehdl')
-- |
canvasZoomUpdateGenRenderCvsId :: MainCoroutine ()
-> CanvasId
-> Maybe ZoomMode
-> Maybe (PageNum,PageCoordinate)
-> MainCoroutine ()
canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode mcoord = do
updateUhdl zoomUpdateAction
adjustScrollbarWithGeometryCvsId cid
xst <- get
let uhdl = view (unitHoodles.currentUnit) xst
hdl = getHoodle uhdl
geometry <- liftIO (getGeometry4CurrCvs uhdl)
let cpn = view (unboxLens currentPageNum) . getCanvasInfo cid $ uhdl
let plst = sortBy ( compare `on` (\(n,_) -> abs (n - cpn)) ) . zip [0..] . F.toList $ hdl ^. gpages
forM_ plst $ \(pn,pg) -> callRenderer_ (updatePageCache geometry (PageNum pn,pg))
renderfunc
where zoomUpdateAction uhdl =
unboxBiAct (fsingle uhdl) (fcont uhdl) . getCanvasInfo cid $ uhdl
fsingle uhdl cinfo = do
geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo
page <- getCurrentPageCvsId cid
let zmode = maybe (cinfo ^. viewInfo.zoomMode) id mzmode
pdim = PageDimension $ page ^. gdimension
xy = either (const (0,0)) (unPageCoord.snd)
(getCvsOriginInPage geometry)
cdim = canvasDim geometry
narr = makeSingleArrangement zmode pdim cdim xy
ncinfobox = CanvasSinglePage
. (viewInfo.pageArrangement .~ narr)
. (viewInfo.zoomMode .~ zmode) $ cinfo
return . modifyCanvasInfo cid (const ncinfobox) $ uhdl
fcont uhdl 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 uhdl
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
. (viewInfo.pageArrangement .~ narr)
. (viewInfo.zoomMode .~ zmode) $ cinfo
return . modifyCanvasInfo cid (const ncinfobox) $ uhdl
-- |
canvasZoomUpdateCvsId :: CanvasId
-> Maybe ZoomMode
-> MainCoroutine ()
canvasZoomUpdateCvsId cid mzmode =
canvasZoomUpdateGenRenderCvsId invalidateAll cid mzmode Nothing
-- |
canvasZoomUpdateBufAll :: MainCoroutine ()
canvasZoomUpdateBufAll = do
klst <- M.keys . view cvsInfoMap . view (unitHoodles.currentUnit) <$> get
mapM_ updatefunc klst
where
updatefunc cid
= canvasZoomUpdateGenRenderCvsId (invalidateInBBox Nothing Efficient cid) cid Nothing Nothing
-- |
canvasZoomUpdateAll :: MainCoroutine ()
canvasZoomUpdateAll = do
klst <- M.keys . view cvsInfoMap . view (unitHoodles.currentUnit) <$> get
mapM_ (flip canvasZoomUpdateCvsId Nothing) klst
-- |
canvasZoomUpdate :: Maybe ZoomMode -> MainCoroutine ()
canvasZoomUpdate mzmode = do
cid <- getCurrentCanvasId . view (unitHoodles.currentUnit) <$> get
canvasZoomUpdateCvsId cid mzmode
-- |
pageZoomChange :: ZoomMode -> MainCoroutine ()
pageZoomChange = canvasZoomUpdate . Just
-- |
pageZoomChangeRel :: ZoomModeRel -> MainCoroutine ()
pageZoomChangeRel rzmode = do
forBoth' unboxBiAct fsingle . view currentCanvasInfo . view (unitHoodles.currentUnit) =<< get
where
fsingle :: CanvasInfo a -> MainCoroutine ()
fsingle cinfo = do
let cpn = PageNum (cinfo ^. currentPageNum)
arr = cinfo ^. viewInfo.pageArrangement
canvas = cinfo ^. drawArea
geometry <- liftIO $ makeCanvasGeometry cpn arr canvas
let nratio = relZoomRatio geometry rzmode
pageZoomChange (Zoom nratio)
-- |
newPage :: Maybe Dimension -> AddDirection -> MainCoroutine ()
newPage mdim dir = (view backgroundStyle <$> get) >>= \bsty ->
updateUhdl (npgBfrAct bsty) >>
commit_ >>
canvasZoomUpdateAll >>
invalidateAll
where
npgBfrAct bsty uhdl = forBoth' unboxBiAct (fsimple bsty uhdl) . view currentCanvasInfo $ uhdl
fsimple :: BackgroundStyle -> UnitHoodle -> CanvasInfo a -> MainCoroutine UnitHoodle
fsimple bsty uhdl cinfo = do
case view hoodleModeState uhdl of
ViewAppendState hdl -> do
hdl' <- addNewPageInHoodle mdim bsty dir hdl (view currentPageNum cinfo)
liftIO . updatePageAll (ViewAppendState hdl')
. set hoodleModeState (ViewAppendState hdl') $ uhdl
SelectState _ -> do
msgShout "newPage: not implemented yet"
return uhdl
-- | delete current page of current canvas
deleteCurrentPage :: MainCoroutine ()
deleteCurrentPage =
updateUhdl delpgact >>
commit_ >>
canvasZoomUpdateAll >>
invalidateAll
where
delpgact uhdl = forBoth' unboxBiAct (fsimple uhdl) . view currentCanvasInfo $ uhdl
fsimple :: UnitHoodle -> CanvasInfo a -> MainCoroutine UnitHoodle
fsimple uhdl cinfo = do
case view hoodleModeState uhdl of
ViewAppendState hdl -> do
hdl' <- liftIO $ deletePageInHoodle hdl
(PageNum (view currentPageNum cinfo))
liftIO . updatePageAll (ViewAppendState hdl')
. set hoodleModeState (ViewAppendState hdl') $ uhdl
SelectState _ -> do
msgShout "deleteCurrentPage: not implemented yet"
return uhdl
-- | 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
-- |
addNewPageInHoodle :: Maybe Dimension
-> BackgroundStyle
-> AddDirection
-> Hoodle EditMode
-> Int
-> MainCoroutine (Hoodle EditMode)
addNewPageInHoodle mdim bsty dir hdl cpn = do
let pagelst = M.elems . view gpages $ hdl
(pagesbefore,cpage:pagesafter) = splitAt cpn pagelst
cbkg = view gbackground cpage
nbkg <- newBkg bsty cbkg
npage <- maybe id (set gdimension) mdim . set gbackground nbkg <$> newPageFromOld cpage
geometry <- liftIO . getGeometry4CurrCvs . view (unitHoodles.currentUnit) =<< get
callRenderer_ (updatePageCache geometry (PageNum cpn,npage))
let npagelst = case dir of
PageBefore -> pagesbefore ++ (npage : cpage : pagesafter)
PageAfter -> pagesbefore ++ (cpage : npage : pagesafter)
nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl
return nhdl
newBkg :: BackgroundStyle -> RBackground -> MainCoroutine RBackground
newBkg bsty bkg = do
xst <- get
let npmode = xst ^. settings.newPageMode
rhdl = (getHoodle . view (unitHoodles.currentUnit)) xst
mtotN = pdfNumPages <$> (rhdl ^. gembeddedpdf)
let bstystr = convertBackgroundStyleToByteString bsty
defbkg = RBkgSmpl "white" bstystr <$> issueSurfaceID
case npmode of
NPPlain -> defbkg
NPLast -> case bkg of
RBkgSmpl c _ _ -> RBkgSmpl c bstystr <$> issueSurfaceID
RBkgPDF d f n pg _ -> RBkgPDF d f n pg <$> issueSurfaceID
RBkgEmbedPDF n pg _ -> RBkgEmbedPDF n pg <$> issueSurfaceID
NPCycle ->
case mtotN of
Nothing -> defbkg
Just totN -> do
let n1 = maybe 1 id (xst ^. nextPdfBkgPageNum)
case findPDFBkg rhdl n1 of
Nothing -> defbkg
Just bkg' -> issueSurfaceID >>= \i -> do
let n' = if n1 >= totN then 1 else (n1+1)
put ((nextPdfBkgPageNum .~ Just n') xst)
return bkg' { rbkg_surfaceid = i }
findPDFBkg :: RHoodle -> Int -> Maybe RBackground
findPDFBkg rhdl n1 =
let bkgs = M.elems (rhdl ^. gpages)
pagematch n (RBkgPDF _ _ n' _ _) = n == n'
pagematch n (RBkgEmbedPDF n' _ _) = n == n'
pagematch _ _ = False
matched = (filter (pagematch n1) . map (^. gbackground)) bkgs
in case matched of
[] -> Nothing
b:_ -> Just b
-- |
newPageFromOld :: Page EditMode -> MainCoroutine (Page EditMode)
newPageFromOld pg = do
sfcid <- issueSurfaceID
return . ( glayers .~ (fromNonEmptyList (emptyRLayer sfcid,[]))) $ pg
updatePageCache :: CanvasGeometry -> (PageNum, Page EditMode) -> Renderer ()
updatePageCache geometry (pnum,page) = do
let Dim w h = page ^. gdimension
CvsCoord (x0,y0) =
(desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (0,0))
CvsCoord (x1,y1) =
(desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (w,h))
updateBkgCache (Dim w h) (Dim (x1-x0) (y1-y0)) (page ^. gbackground)
mapM_ (updateLayerCache (Dim w h) (Dim (x1-x0) (y1-y0))) (F.toList (page ^. glayers))
updateBkgCache :: Dimension -> Dimension -> RBackground -> Renderer ()
updateBkgCache dimo dimv rbkg = do
RendererState _handler qpdf qgen _ <- ask
let sfcid = rbkg_surfaceid rbkg
case rbkg of
RBkgSmpl {..} -> do
cmdid <- issueGenCommandID
(liftIO . atomically) (sendGenCommand qgen cmdid (BkgSmplScaled sfcid rbkg_color rbkg_style dimo dimv))
return ()
_ -> F.forM_ (rbkg_popplerpage rbkg) $ \pg -> do
cmdid <- issuePDFCommandID
(liftIO . atomically) (sendPDFCommand qpdf cmdid (RenderPageScaled sfcid pg dimo dimv))
return ()
updateLayerCache :: Dimension -> Dimension -> RLayer -> Renderer ()
updateLayerCache dimo dimv lyr = do
RendererState _ _ qgen _ <- ask
case view gbuffer lyr of
LyBuf sfcid -> do
cmdid <- issueGenCommandID
(liftIO . atomically) (sendGenCommand qgen cmdid (LayerScaled sfcid (view gitems lyr) dimo dimv))
return ()