module Application.HXournal.Draw where import Graphics.UI.Gtk hiding (get) import Graphics.Rendering.Cairo import Control.Applicative import Control.Category import Data.Label import Prelude hiding ((.),id) import Text.Xournal.Type import Graphics.Xournal.Type import Graphics.Xournal.Type.Select import Graphics.Xournal.Type.Map import Graphics.Xournal.Render import Graphics.Xournal.Render.BBox import Graphics.Xournal.HitTest import Application.HXournal.Type import Application.HXournal.Device data CanvasPageGeometry = CanvasPageGeometry { screen_size :: (Double,Double) , canvas_size :: (Double,Double) , page_size :: (Double,Double) , canvas_origin :: (Double,Double) , page_origin :: (Double,Double) } deriving (Show) type PageDrawF = DrawingArea -> PageBBoxMap -> ViewInfo -> Maybe BBox -> IO () type PageDrawFSel = DrawingArea -> TempPageSelect -> ViewInfo -> Maybe BBox -> IO () getCanvasPageGeometry :: IPage a => DrawingArea -> a -> (Double,Double) -> IO CanvasPageGeometry getCanvasPageGeometry canvas page (xorig,yorig) = do win <- widgetGetDrawWindow canvas (w',h') <- widgetGetSize canvas screen <- widgetGetScreen canvas (ws,hs) <- (,) <$> screenGetWidth screen <*> screenGetHeight screen let (Dim w h) = pageDim page (x0,y0) <- drawWindowGetOrigin win return $ CanvasPageGeometry (fromIntegral ws, fromIntegral hs) (fromIntegral w', fromIntegral h') (w,h) (fromIntegral x0,fromIntegral y0) (xorig, yorig) core2pageCoord :: CanvasPageGeometry -> ZoomMode -> (Double,Double) -> (Double,Double) core2pageCoord cpg@(CanvasPageGeometry (_ws,_hs) (_w',_h') (_w,_h) (_x0,_y0) (xorig,yorig)) zmode (px,py) = let s = 1.0 / getRatioFromPageToCanvas cpg zmode (xo,yo) = case zmode of Original -> (xorig,yorig) FitWidth -> (0,yorig) FitHeight -> (xorig,0) _ -> error "not implemented yet in core2pageCoord" in (px*s+xo, py*s+yo) wacom2pageCoord :: CanvasPageGeometry -> ZoomMode -> (Double,Double) -> (Double,Double) wacom2pageCoord cpg@(CanvasPageGeometry (ws,hs) (_w',_h') (_w,_h) (x0,y0) (xorig,yorig)) zmode (px,py) = let (x1,y1) = (ws*px-x0,hs*py-y0) s = 1.0 / getRatioFromPageToCanvas cpg zmode (xo,yo) = case zmode of Original -> (xorig,yorig) FitWidth -> (0,yorig) FitHeight -> (xorig,0) _ -> error "not implemented wacom2pageCoord" in (x1*s+xo,y1*s+yo) device2pageCoord :: CanvasPageGeometry -> ZoomMode -> PointerCoord -> (Double,Double) device2pageCoord cpg zmode pcoord@(PointerCoord _ _ _) = let (px,py) = (,) <$> pointerX <*> pointerY $ pcoord in case pointerType pcoord of Core -> core2pageCoord cpg zmode (px,py) _ -> wacom2pageCoord cpg zmode (px,py) device2pageCoord _ _ NoPointerCoord = (-100,-100) transformForPageCoord :: CanvasPageGeometry -> ZoomMode -> Render () transformForPageCoord cpg zmode = do let (xo,yo) = page_origin cpg let s = getRatioFromPageToCanvas cpg zmode scale s s translate (-xo) (-yo) updateCanvas :: DrawingArea -> XournalBBox -> Int -> ViewInfo -> IO () updateCanvas canvas xoj pagenum vinfo = do let zmode = get zoomMode vinfo origin = get viewPortOrigin vinfo let currpage = ((!!pagenum).xournalPages) xoj geometry <- getCanvasPageGeometry canvas currpage origin win <- widgetGetDrawWindow canvas renderWithDrawable win $ do transformForPageCoord geometry zmode cairoDrawPage currpage return () drawBBoxOnly :: PageDrawF drawBBoxOnly canvas page vinfo _mbbox = do let zmode = get zoomMode vinfo origin = get viewPortOrigin vinfo geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas renderWithDrawable win $ do transformForPageCoord geometry zmode cairoDrawPageBBoxOnly page return () drawPageInBBox :: PageDrawF drawPageInBBox canvas page vinfo mbbox = do let zmode = get zoomMode vinfo origin = get viewPortOrigin vinfo geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas renderWithDrawable win $ do transformForPageCoord geometry zmode cairoDrawPageBBox mbbox page return () return () drawBBox :: PageDrawF drawBBox _ _ _ Nothing = return () drawBBox canvas page vinfo (Just bbox) = do let zmode = get zoomMode vinfo origin = get viewPortOrigin vinfo geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas renderWithDrawable win $ do setLineWidth 0.5 setSourceRGBA 1.0 0.0 0.0 1.0 transformForPageCoord geometry zmode let (x1,y1) = bbox_upperleft bbox (x2,y2) = bbox_lowerright bbox rectangle x1 y1 (x2-x1) (y2-y1) stroke return () drawBBoxSel :: PageDrawFSel drawBBoxSel _ _ _ Nothing = return () drawBBoxSel canvas tpg vinfo (Just bbox) = do let page = pageBBoxMapFromTempPageSelect tpg let zmode = get zoomMode vinfo origin = get viewPortOrigin vinfo geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas renderWithDrawable win $ do setLineWidth 0.5 setSourceRGBA 1.0 0.0 0.0 1.0 transformForPageCoord geometry zmode let (x1,y1) = bbox_upperleft bbox (x2,y2) = bbox_lowerright bbox rectangle x1 y1 (x2-x1) (y2-y1) stroke return () getRatioFromPageToCanvas :: CanvasPageGeometry -> ZoomMode -> Double getRatioFromPageToCanvas _cpg Original = 1.0 getRatioFromPageToCanvas cpg FitWidth = let (w,_) = page_size cpg (w',_) = canvas_size cpg in w'/w getRatioFromPageToCanvas cpg FitHeight = let (_,h) = page_size cpg (_,h') = canvas_size cpg in h'/h getRatioFromPageToCanvas _cpg (Zoom s) = s drawSegment :: DrawingArea -> CanvasPageGeometry -> ZoomMode -> Double -> (Double,Double,Double,Double) -> (Double,Double) -> (Double,Double) -> IO () drawSegment canvas cpg zmode wdth (r,g,b,a) (x0,y0) (x,y) = do win <- widgetGetDrawWindow canvas renderWithDrawable win $ do transformForPageCoord cpg zmode setSourceRGBA r g b a setLineWidth wdth moveTo x0 y0 lineTo x y stroke showXournalBBox :: DrawingArea -> XournalBBox -> Int -> ViewInfo -> IO () showXournalBBox canvas xojbbox pagenum vinfo = do let zmode = get zoomMode vinfo origin = get viewPortOrigin vinfo let currpagebbox = ((!!pagenum).xojbbox_pages) xojbbox currpage = pageFromPageBBox currpagebbox strs = do l <- pagebbox_layers currpagebbox s <- layerbbox_strokes l return s geometry <- getCanvasPageGeometry canvas currpage origin win <- widgetGetDrawWindow canvas renderWithDrawable win $ do transformForPageCoord geometry zmode setSourceRGBA 1.0 0 0 1.0 setLineWidth 0.5 let f str = do let BBox (ulx,uly) (lrx,lry) = strokebbox_bbox str rectangle ulx uly (lrx-ulx) (lry-uly) stroke mapM_ f strs return () showBBox :: DrawingArea -> CanvasPageGeometry -> ZoomMode -> BBox -> IO () showBBox canvas cpg zmode (BBox (ulx,uly) (lrx,lry)) = do win <- widgetGetDrawWindow canvas renderWithDrawable win $ do transformForPageCoord cpg zmode setSourceRGBA 0.0 1.0 0.0 1.0 setLineWidth 1.0 rectangle ulx uly (lrx-ulx) (lry-uly) stroke return () dummyDraw :: PageDrawFSel dummyDraw _canvas _pgslct _vinfo _mbbox = do putStrLn "dummy draw" return () drawSelectionInBBox :: PageDrawFSel drawSelectionInBBox canvas tpg vinfo mbbox = do let zmode = get zoomMode vinfo origin = get viewPortOrigin vinfo page = pageBBoxMapFromTempPageSelect tpg geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas boxdrawaction <- case strokes (tp_firstlayer tpg) of Right alist -> do return $ do setSourceRGBA 0.0 0.0 1.0 1.0 let hitstrs = concatMap unHitted (getB alist) oneboxdraw str = do let bbox@(BBox (x1,y1) (x2,y2)) = strokebbox_bbox str drawbox = do { rectangle x1 y1 (x2-x1) (y2-y1); stroke } case mbbox of Just bboxarg -> if hitTestBBoxBBox bbox bboxarg then drawbox else return () Nothing -> drawbox mapM_ oneboxdraw hitstrs Left _ -> return $ return () renderWithDrawable win $ do transformForPageCoord geometry zmode cairoDrawPageBBox mbbox page boxdrawaction