{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Page -- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.Coroutine.Page where import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Lens (view,set,over, (.~), (^.) ) 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) import Data.UUID.V4 import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk as Gtk import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.Select import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Zipper import Graphics.Hoodle.Render -- import Graphics.Hoodle.Render.Background 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.Event 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) . (^. currentCanvasInfo) $ xst fsingle xstate cvsInfo = do let xojst = view hoodleModeState $ xstate npgnum = modifyfn (cvsInfo ^. currentPageNum) cid = view canvasId cvsInfo bsty = view backgroundStyle xstate (b,npgnum',_,xojst') <- changePageInHoodleModeState bsty npgnum xojst xstate' <- liftIO $ updatePageAll xojst' xstate ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid let xstatefinal = (currentCanvasInfo .~ ncvsInfo) xstate' when b (commit xstatefinal) return xstatefinal fcont xstate cvsInfo = do let xojst = view hoodleModeState xstate npgnum = modifyfn (cvsInfo ^. currentPageNum) cid = cvsInfo ^. canvasId bsty = xstate ^. backgroundStyle (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 -> 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 =<< get callRenderer $ updateBkgCache geometry (PageNum (totnumpages-1),npage) >> return GotNone waitSomeEvent (\case RenderEv GotNone -> True ; _ -> False ) 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 updateXState zoomUpdateAction adjustScrollbarWithGeometryCvsId cid xst <- get let hdl = getHoodle xst geometry <- liftIO (getGeometry4CurrCvs xst) let cpn = view (unboxLens currentPageNum) . getCanvasInfo cid $ xst let plst = sortBy ( compare `on` (\(n,_) -> abs (n - cpn)) ) . zip [0..] . F.toList $ hdl ^. gpages forM_ plst $ \(pn,pg) -> callRenderer_ (updateBkgCache geometry (PageNum pn,pg)) 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 (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) $ 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 . (viewInfo.pageArrangement .~ narr) . (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 (cinfo ^. currentPageNum) arr = cinfo ^. viewInfo.pageArrangement canvas = cinfo ^. drawArea 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 -- | addNewPageInHoodle :: BackgroundStyle -> AddDirection -> Hoodle EditMode -> Int -> MainCoroutine (Hoodle EditMode) addNewPageInHoodle 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 <- set gbackground nbkg <$> newPageFromOld cpage geometry <- liftIO . getGeometry4CurrCvs =<< get callRenderer_ (updateBkgCache 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 let bstystr = convertBackgroundStyleToByteString bsty case bkg of RBkgSmpl c _ _ -> RBkgSmpl c bstystr <$> liftIO nextRandom _ -> RBkgSmpl "white" bstystr <$> liftIO nextRandom -- | newPageFromOld :: Page EditMode -> MainCoroutine (Page EditMode) newPageFromOld = return . ( glayers .~ (fromNonEmptyList (emptyRLayer,[]))) updateBkgCache :: CanvasGeometry -> (PageNum, Page EditMode) -> Renderer () updateBkgCache geometry (pnum,page) = do (handler,qvar) <- ask let dim@(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)) s = (x1-x0) / w rbkg = page ^. gbackground bkg = rbkg2Bkg rbkg uuid = rbkg_uuid rbkg case rbkg of RBkgSmpl {..} -> do liftIO . forkIO $ do sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor (x1-x0)) (floor (y1-y0)) Cairo.renderWith sfc $ Cairo.scale s s >> renderBkg (bkg,dim) handler (uuid, (s,sfc)) return () _ -> F.forM_ (rbkg_popplerpage rbkg) $ \pg -> do (liftIO . atomically) (sendPDFCommand uuid qvar (RenderPageScaled pg (Dim w h) (Dim (x1-x0) (y1-y0)))) return ()