----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.VerticalSpace -- Copyright : (c) 2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.Coroutine.VerticalSpace where import Control.Applicative import Control.Category import Control.Lens (view,set,at) import Control.Monad hiding (mapM_) import Control.Monad.State (get) import Data.Foldable import Data.Monoid import Data.Time.Clock import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Zipper (SeqZipper,toSeq) import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Type.HitTest import Graphics.Hoodle.Render.Type.Hoodle import Graphics.Hoodle.Render.Type.Item import Graphics.Hoodle.Render.Util.HitTest -- from this package import Hoodle.Accessor import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Page import Hoodle.Coroutine.Pen import Hoodle.Device import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select.Transform 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.Type.Predefined import Hoodle.View.Coordinate import Hoodle.View.Draw -- import Prelude hiding ((.), id, concat,concatMap,mapM_) -- | splitPageByHLine :: Double -> Page EditMode -> ([RItem],Page EditMode,SeqZipper RItemHitted) splitPageByHLine y pg = (hitted,set glayers unhitted pg,hltedLayers) where alllyrs = view glayers pg findHittedItmsInALyr = hltFilteredBy (bboxabove . getBBox) . view gitems hltedLayers = fmap findHittedItmsInALyr alllyrs unhitted = fmap (\lyr -> (\x->set gitems x lyr) . concatMap unNotHitted . getA . findHittedItmsInALyr $ lyr) alllyrs hitted = (concat . fmap (concatMap unHitted . getB . findHittedItmsInALyr) . toSeq ) alllyrs bboxabove (BBox (_,y0) _) = y0 > y -- | verticalSpaceStart :: CanvasId -> PointerCoord -> MainCoroutine () verticalSpaceStart cid = commonPenStart verticalSpaceAction cid where verticalSpaceAction _cinfo pnum@(PageNum n) geometry (x,y) = do hdl <- liftM getHoodle get cpg <- getCurrentPageCurr let (itms,npg,hltedLayers) = splitPageByHLine y cpg nhdl = set (gpages.at n) (Just npg) hdl mbbx = (toMaybe . mconcat . fmap (Union . Middle . getBBox)) itms case mbbx of Nothing -> return () Just bbx -> do (sfcbkg,Dim w h) <- liftIO $ canvasImageSurface Nothing geometry nhdl sfcitm <- liftIO $ createImageSurface FormatARGB32 (floor w) (floor h) sfctot <- liftIO $ createImageSurface FormatARGB32 (floor w) (floor h) liftIO $ renderWith sfcitm $ do identityMatrix cairoXform4PageCoordinate geometry pnum mapM_ renderRItem itms ctime <- liftIO getCurrentTime verticalSpaceProcess cid geometry (bbx,hltedLayers,pnum,cpg) (x,y) (sfcbkg,sfcitm,sfctot) ctime liftIO $ mapM_ surfaceFinish [sfcbkg,sfcitm,sfctot] -- | addNewPageAndMoveBelow :: (PageNum,SeqZipper RItemHitted,BBox) -> MainCoroutine () addNewPageAndMoveBelow (pnum,hltedLyrs,bbx) = 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 PageAfter hdl (unPageNum pnum) hdl'' = moveBelowToNewPage (pnum,hltedLyrs,bbx) hdl' nhdlmodst = ViewAppendState hdl'' return =<< liftIO . updatePageAll nhdlmodst . set hoodleModeState nhdlmodst $ xstate SelectState _ -> do liftIO $ putStrLn " not implemented yet" return xstate -- | moveBelowToNewPage :: (PageNum,SeqZipper RItemHitted,BBox) -> Hoodle EditMode -> Hoodle EditMode moveBelowToNewPage (PageNum n,hltedLayers,BBox (_,y0) _) hdl = let mpg = view (gpages.at n) hdl mpg2 = view (gpages.at (n+1)) hdl in case (,) <$> mpg <*> mpg2 of Nothing -> hdl Just (pg,pg2) -> let nhlyrs = -- 10 is just a predefined number fmap (fmapAL id (fmap (changeItemBy (\(x',y')->(x',y'+10-y0))))) hltedLayers nlyrs = fmap ((\x -> set gitems x emptyRLayer) . concatMap unNotHitted . getA ) nhlyrs npg = set glayers nlyrs pg nnlyrs = fmap ((\x -> set gitems x emptyRLayer) . concatMap unHitted . getB ) nhlyrs npg2 = set glayers nnlyrs pg2 nhdl = ( set (gpages.at (n+1)) (Just npg2) . set (gpages.at n) (Just npg) ) hdl in nhdl -- | verticalSpaceProcess :: CanvasId -> CanvasGeometry -> (BBox,SeqZipper RItemHitted,PageNum,Page EditMode) -> (Double,Double) -> (Surface,Surface,Surface) -> UTCTime -> MainCoroutine () verticalSpaceProcess cid geometry pinfo@(bbx,hltedLayers,pnum@(PageNum n),pg) (x0,y0) sfcs@(sfcbkg,sfcitm,sfctot) otime = do r <- nextevent xst <- get forBoth' unboxBiAct (f r xst) . getCanvasInfo cid $ xst where Dim w h = view gdimension pg CvsCoord (_,y0_cvs) = (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (x0,y0)) ------------------------------------------------------------- f :: UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine () f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cvsInfo) upact ------------------------------------------------------------- defact = verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs otime ------------------------------------------------------------- upact pcoord = do let mpgcoord = (desktop2Page geometry . device2Desktop geometry) pcoord case mpgcoord of Nothing -> invalidateAll Just (cpn,PageCoord (_,y)) -> if cpn /= pnum then invalidateAll else do -- add space within this page let BBox _ (_,by1) = bbx if by1 + y - y0 < h then do xst <- get let hdl = getHoodle xst let nhlyrs = fmap (fmapAL id (fmap (changeItemBy (\(x',y')->(x',y'+y-y0))))) hltedLayers nlyrs = fmap ((\is -> set gitems is emptyRLayer) . concat . interleave unNotHitted unHitted) nhlyrs npg = set glayers nlyrs pg nhdl = set (gpages.at n) (Just npg) hdl commit (set hoodleModeState (ViewAppendState nhdl) xst) invalidateAll else do addNewPageAndMoveBelow (pnum,hltedLayers,bbx) ------------------------------------------------------------- moveact _xstate cvsInfo (_,(x,y)) = processWithDefTimeInterval (verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs) (\ctime -> do let CvsCoord (_,y_cvs) = (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (x,y)) BBox _ (_,by1) = bbx mode | by1 + y - y0 > h = OverPage | y > y0 = GoingDown | otherwise = GoingUp z = canvas2DesktopRatio geometry drawguide = do identityMatrix cairoXform4PageCoordinate geometry pnum setLineWidth (predefinedLassoWidth*z) case mode of GoingUp -> setSourceRGBA 0.1 0.8 0.1 0.4 GoingDown -> setSourceRGBA 0.1 0.1 0.8 0.4 OverPage -> setSourceRGBA 0.8 0.1 0.1 0.4 moveTo 0 y0 lineTo w y0 stroke moveTo 0 y lineTo w y stroke case mode of GoingUp -> setSourceRGBA 0.1 0.8 0.1 0.2 >> rectangle 0 y w (y0-y) GoingDown -> setSourceRGBA 0.1 0.1 0.8 0.2 >> rectangle 0 y0 w (y-y0) OverPage -> setSourceRGBA 0.8 0.1 0.1 0.2 >> rectangle 0 y0 w (y-y0) fill liftIO $ renderWith sfctot $ do setSourceSurface sfcbkg 0 0 setOperator OperatorSource paint setSourceSurface sfcitm 0 (y_cvs-y0_cvs) setOperator OperatorOver paint drawguide let canvas = view drawArea cvsInfo win <- liftIO $ widgetGetDrawWindow canvas liftIO $ renderWithDrawable win $ do setSourceSurface sfctot 0 0 setOperator OperatorSource paint verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs ctime) otime