Draw.hs

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 Data.Monoid
import Data.Xournal.Simple
import Data.Xournal.Generic

import Data.Xournal.BBox
import Graphics.Xournal.Render.Type

import Graphics.Xournal.Render.BBox 
import Graphics.Xournal.Render.BBoxMapPDF 
import Graphics.Xournal.Render.PDFBackground
import Graphics.Xournal.Render.Generic
import Graphics.Xournal.Render.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 -> TPageBBoxMapPDFBuf -> ViewInfo -> Maybe BBox 
                 -> IO ()

type PageDrawFSel = DrawingArea -> TTempPageSelectPDFBuf -> ViewInfo -> Maybe BBox 
                    -> IO ()


getCanvasPageGeometry :: DrawingArea 
                         -> GPage b s 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) = gdimension page
  (x0,y0) <- drawWindowGetOrigin win
  return $ CanvasPageGeometry (fromIntegral ws, fromIntegral hs) 
                              (fromIntegral w', fromIntegral h') 
                              (w,h) 
                              (fromIntegral x0,fromIntegral y0)
                              (xorig, yorig)

visibleViewPort :: CanvasPageGeometry -> ZoomMode -> BBox  
visibleViewPort cpg@(CanvasPageGeometry (_ws,_hs) (w',h') (_w,_h) (_x0,_y0) (xorig,yorig)) zmode = 
  let (xend,yend) = canvasToPageCoord cpg zmode (w',h')
  in  BBox (xorig,yorig) (xend,yend)


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)

pageToCanvasCoord :: CanvasPageGeometry -> ZoomMode -> (Double,Double) -> (Double,Double)
pageToCanvasCoord cpg@(CanvasPageGeometry _ _ _ _ (xorig,yorig)) zmode (x,y) = 
  let s = getRatioFromPageToCanvas cpg zmode
      (xo,yo) = case zmode of 
                  Original -> (xorig,yorig)
                  FitWidth -> (0,yorig)
                  FitHeight -> (xorig,0)
                  _ -> error "not implemented yet in pageToScreenCoord"
  in ((x-xo)*s,(y-yo)*s)

canvasToPageCoord :: CanvasPageGeometry -> ZoomMode -> (Double,Double) -> (Double,Double) 
canvasToPageCoord = core2pageCoord

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)      
  

drawFuncGen :: (TPageBBoxMapPDFBuf -> Maybe BBox -> Render ()) -> PageDrawF 
drawFuncGen render canvas page vinfo mbbox = do 
  let zmode  = get zoomMode vinfo
      origin = get viewPortOrigin vinfo
  geometry <- getCanvasPageGeometry canvas page origin
  win <- widgetGetDrawWindow canvas
  let mbboxnew = adjustBBoxWithView geometry zmode mbbox
  renderWithDrawable win $ do
    transformForPageCoord geometry zmode
    clipBBox mbboxnew
    render page mbboxnew 
    resetClip 
    return ()
  return ()
  
drawFuncSelGen :: (TTempPageSelectPDFBuf -> Maybe BBox -> Render ()) 
                  -> (TTempPageSelectPDFBuf -> Maybe BBox -> Render ())
                  -> PageDrawFSel  
drawFuncSelGen rencont rensel canvas page vinfo mbbox = do 
  let zmode  = get zoomMode vinfo
      origin = get viewPortOrigin vinfo
  geometry <- getCanvasPageGeometry canvas page origin
  win <- widgetGetDrawWindow canvas
  let mbboxnew = adjustBBoxWithView geometry zmode mbbox
  renderWithDrawable win $ do
    transformForPageCoord geometry zmode
    clipBBox mbboxnew
    rencont page mbboxnew 
    rensel page mbboxnew 
    resetClip 
  return ()
  


drawPageClearly :: PageDrawF
drawPageClearly = drawFuncGen $ \page _mbbox -> 
                     cairoRenderOption (DrawBkgPDF,DrawFull) (gcast page :: TPageBBoxMapPDF)
                     
drawPageSelClearly :: PageDrawFSel                      
drawPageSelClearly = drawFuncSelGen rendercontent renderselect 
  where rendercontent tpg _mbbox = do
          let pg = (gcast tpg :: TPageBBoxMapPDFBuf)
          cairoRenderOption (DrawBkgPDF,DrawFull) (gcast pg :: TPageBBoxMapPDF)
        renderselect tpg mbbox = 
          cairoHittedBoxDraw tpg mbbox




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
    cairoRenderOption (DrawWhite,DrawBoxOnly) (gcast page :: TPageBBoxMapPDF)
     --  tpageBBoxMapPDFFromTPageBBoxMapPDFBuf page )
  return ()

adjustBBoxWithView :: CanvasPageGeometry -> ZoomMode -> Maybe BBox 
                      -> Maybe BBox
adjustBBoxWithView geometry zmode mbbox =   
  let viewbbox = visibleViewPort geometry zmode
  in  toMaybe $ (fromMaybe mbbox :: IntersectBBox)  
                `mappend` 
                (Intersect (Middle viewbbox))


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
  let mbboxnew = adjustBBoxWithView geometry zmode mbbox
  renderWithDrawable win $ do
    transformForPageCoord geometry zmode
    cairoRenderOption (InBBoxOption mbboxnew) (InBBox page) --  (InBBox (gcast page :: TPageBBoxMapPDF))
    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 = (gcast tpg :: TPageBBoxMapPDFBuf)
  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
  

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 = (gcast tpg :: TPageBBoxMapPDFBuf)
  geometry <- getCanvasPageGeometry canvas page origin
  win <- widgetGetDrawWindow canvas
  let mbboxnew = adjustBBoxWithView geometry zmode mbbox
  renderWithDrawable win $ do
    transformForPageCoord geometry zmode
    cairoRenderOption (InBBoxOption mbboxnew) (InBBox page)
       -- (InBBox (gcast page :: TPageBBoxMapPDF))
    cairoHittedBoxDraw tpg mbboxnew  
      
{-
drawSelectionInBBoxOnly :: PageDrawFSel 
drawSelectionInBBoxOnly canvas tpg vinfo mbbox = do 
  let zmode  = get zoomMode vinfo
      origin = get viewPortOrigin vinfo
      page = (gcast tpg :: TPageBBoxMapPDFBuf)
  geometry <- getCanvasPageGeometry canvas page origin
  win <- widgetGetDrawWindow canvas  
  let mbboxnew = adjustBBoxWithView geometry zmode mbbox
  renderWithDrawable win $ do
    transformForPageCoord geometry zmode
    cairoRenderOption (InBBoxOption mbboxnew) (InBBox page)
      -- (DrawWhite,DrawBoxOnly) (gcast page :: TPageBBoxMapPDF)
      -- (DrawBuffer,DrawBoxOnly) (gcast page :: TPageBBoxMapPDF)
    cairoHittedBoxDraw tpg mbbox 
-}
  
cairoHittedBoxDraw :: TTempPageSelectPDFBuf -> Maybe BBox -> Render () 
cairoHittedBoxDraw tpg mbbox = do   
  let layers = get g_layers tpg 
      slayer = gselectedlayerbuf layers 
  case unTEitherAlterHitted . get g_bstrokes $ slayer of
    Right alist -> do 
      clipBBox mbbox
      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                       
      resetClip
    Left _ -> return ()  

---- 
    
drawBuf :: PageDrawF 
drawBuf canvas page vinfo mbbox = do 
  let zmode  = get zoomMode vinfo
      origin = get viewPortOrigin vinfo
  geometry <- getCanvasPageGeometry canvas page origin
  let mbboxnew = adjustBBoxWithView geometry zmode mbbox
  win <- widgetGetDrawWindow canvas
  renderWithDrawable win $ do
    transformForPageCoord geometry zmode
    cairoRenderOption (InBBoxOption mbboxnew) (InBBox page) 
    return ()
  return ()


drawSelBuf :: PageDrawFSel 
drawSelBuf canvas tpg vinfo mbbox = do 
  let zmode  = get zoomMode vinfo
      origin = get viewPortOrigin vinfo
      page = (gcast tpg :: TPageBBoxMapPDFBuf)
  geometry <- getCanvasPageGeometry canvas page origin
  win <- widgetGetDrawWindow canvas
  renderWithDrawable win $ do
    transformForPageCoord geometry zmode
    cairoRenderOption (InBBoxOption mbbox) (InBBox (gcast page :: TPageBBoxMapPDF))
    cairoHittedBoxDraw tpg mbbox