hoodle-render 0.2.1 → 0.3

raw patch · 14 files changed

+443/−307 lines, 14 filesdep +monad-loopsdep +unixdep +uuiddep −TypeComposedep ~hoodle-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: monad-loops, unix, uuid

Dependencies removed: TypeCompose

Dependency ranges changed: hoodle-types

API changes (from Hackage documentation)

Files

• hoodle-render.cabal +19/−13
• src/Graphics/Hoodle/Render.hs +111/−124
• src/Graphics/Hoodle/Render/Background.hs +95/−15
• src/Graphics/Hoodle/Render/Debug.hs +17/−10
• src/Graphics/Hoodle/Render/Generic.hs +4/−4
• src/Graphics/Hoodle/Render/Highlight.hs +25/−9
• src/Graphics/Hoodle/Render/Item.hs +31/−10
• src/Graphics/Hoodle/Render/Type/Background.hs +12/−16
• src/Graphics/Hoodle/Render/Type/HitTest.hs +8/−3
• src/Graphics/Hoodle/Render/Type/Hoodle.hs +3/−1
• src/Graphics/Hoodle/Render/Type/Item.hs +20/−11
• src/Graphics/Hoodle/Render/Type/Select.hs +3/−15
• src/Graphics/Hoodle/Render/Util/HitTest.hs +6/−76
• src/Hoodle/Util/Process.hs +89/−0

@@ -1,5 +1,5 @@ Name:		hoodle-render-Version:	0.2.1+Version:	0.3 Synopsis:       Hoodle file renderer Description: 	Rendering library using cairo for hoodle file format License: 	BSD3@@ -14,9 +14,9 @@   type: git   location: http://www.github.com/wavewave/hoodle-render -Flag Poppler-  Description: Enable poppler support-  Default:     False+-- Flag Poppler+--   Description: Enable poppler support+--   Default:     False  Library   hs-source-dirs: src@@ -34,14 +34,18 @@                  bytestring >= 0.9,                  base64-bytestring >= 0.1,                   lens >= 2.5, -                 hoodle-types >= 0.1.1,-                 TypeCompose == 0.9.*, -                 gd >= 3000.7 +                 hoodle-types >= 0.2,+                 gd >= 3000.7, +                 unix >= 2.5,+                 uuid >= 1.2, +                 monad-loops >= 0.3,  +                 -- hoodle-common >= 0.1,+                 poppler >= 0.12.2.2 -  if flag(poppler)-    Build-Depends: poppler >= 0.12.2.2-  else -    Build-Depends: +--   if flag(poppler)+--    Build-Depends: poppler >= 0.12.2.2+--  else +--     Build-Depends:     Exposed-Modules:                     Graphics.Hoodle.Render @@ -59,5 +63,7 @@                    Graphics.Hoodle.Render.Type.Select                    Graphics.Hoodle.Render.Util                    Graphics.Hoodle.Render.Util.HitTest-  if flag(poppler)-    cpp-options: -DPOPPLER+                   Hoodle.Util.Process++--  if flag(poppler)+--    cpp-options: -DPOPPLER

@@ -25,7 +25,7 @@ , renderItem  , renderPage -- * render in bbox using non R-structure -, renderBkg_InBBox+-- , renderBkg_InBBox -- * simple rendering using R-structure  , renderRBkg , renderRItem @@ -47,21 +47,21 @@ ) where  import           Control.Lens (view,set)+import           Control.Monad.Identity (runIdentity) import           Control.Monad.State hiding (mapM,mapM_) import qualified Data.ByteString.Char8 as C import           Data.Foldable import           Data.Traversable (mapM)-import qualified Data.Map as M-import           Data.Monoid+-- import qualified Data.Map as M+-- import           Data.Monoid import           Graphics.Rendering.Cairo -- from hoodle-platform -import Data.Hoodle.Generic-import Data.Hoodle.Simple-import Data.Hoodle.BBox-import Data.Hoodle.Predefined -#ifdef POPPLER+import           Data.Hoodle.Generic+import           Data.Hoodle.Simple+import           Data.Hoodle.BBox+import           Data.Hoodle.Predefined +import           Data.Hoodle.Zipper  import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage-#endif import qualified Graphics.Rendering.Cairo.SVG as RSVG -- from this package -- import Graphics.Hoodle.Render.Simple @@ -114,13 +114,13 @@       rectangle x y w h       stroke --- | render svg : not fully implemented +-- | render svg   renderSVG :: SVG -> Render ()  renderSVG svg@(SVG _ _ bstr _ _) = do       let str = C.unpack bstr      RSVG.withSvgFromString str $ \rsvg -> do -      let svgbbx = mkSVGBBox svg-      let (x,y) = (svg_pos . svgbbx_svg) svgbbx+      let svgbbx = runIdentity (makeBBoxed svg)+      let (x,y) = (svg_pos . bbxed_content) svgbbx           BBox (x1,y1) (x2,y2) = getBBox svgbbx           (ix',iy') = RSVG.svgGetSize rsvg           ix = fromIntegral ix' @@ -134,28 +134,34 @@       resetClip        return ()  +-- | render svg  +renderLink :: Link -> Render () +renderLink lnk = do  +    let bstr = link_render lnk +    let str = C.unpack bstr +    RSVG.withSvgFromString str $ \rsvg -> do +      let lnkbbx = runIdentity (makeBBoxed lnk)+      let (x,y) = (link_pos . bbxed_content) lnkbbx+          BBox (x1,y1) (x2,y2) = getBBox lnkbbx+          (ix',iy') = RSVG.svgGetSize rsvg+          ix = fromIntegral ix' +          iy = fromIntegral iy'+      clipBBox (Just (getBBox lnkbbx))+      save +      translate x y +      scale ((x2-x1)/ix) ((y2-y1)/iy)+      RSVG.svgRender rsvg +      restore+      resetClip +      return ()  + -- | render item  renderItem :: Item -> Render ()  renderItem (ItemStroke strk) = renderStrk strk renderItem (ItemImage img) = renderImg img renderItem (ItemSVG svg) = renderSVG svg---- | render background without any constraint -renderBkg :: (Background,Dimension) -> Render () -renderBkg (Background _typ col sty,Dim w h) = do -    let c = M.lookup col predefined_bkgcolor  -    case c of -      Just (r,g,b,_a) -> setSourceRGB r g b -      Nothing        -> setSourceRGB 1 1 1 -    rectangle 0 0 w h -    fill-    drawRuling w h sty-renderBkg (BackgroundPdf _ _ _ _,Dim w h) = do -    setSourceRGBA 1 1 1 1-    rectangle 0 0 w h -    fill-+renderItem (ItemLink lnk) = renderLink lnk  -- | renderPage :: Page -> Render ()@@ -166,73 +172,63 @@   mapM_ (mapM renderItem . view items) . view layers $ page   stroke ---- --- non-R but in bbox ----  ---- | render Background in BBox -renderBkg_InBBox :: Maybe BBox -> Dimension -> Background -> Render ()-renderBkg_InBBox mbbox dim@(Dim w h) (Background typ col sty) = do -    let mbbox2 = toMaybe $ fromMaybe mbbox `mappend` (Intersect (Middle (dimToBBox dim)))-    case mbbox2 of -      Nothing -> renderBkg (Background typ col sty,Dim w h)-      Just bbox@(BBox (x1,y1) (x2,y2)) -> do -        let c = M.lookup col predefined_bkgcolor  -        case c of -          Just (r,g,b,_a) -> setSourceRGB r g b -          Nothing        -> setSourceRGB 1 1 1 -        rectangle x1 y1 (x2-x1) (y2-y1)-        fill-        drawRuling_InBBox bbox w h sty-renderBkg_InBBox _ _  (BackgroundPdf _ _ _ _) = -    error "BackgroundPdf in renderBkg_InBBox"- ----- -- R-structure  ----  -- |  renderRBkg :: (RBackground,Dimension) -> Render (RBackground,Dimension)-renderRBkg (r@(RBkgSmpl _ _ _),dim) = renderBkg (rbkg2Bkg r,dim) >> return (r,dim)-renderRBkg (r@(RBkgPDF _ _ _ p _),dim) = do-  case p of -    Nothing -> return () -    Just pg -> do +renderRBkg (r,dim) = +    case r of +      (RBkgSmpl _ _ _) -> +        drawBkgAndRecord (renderBkg (rbkg2Bkg r,dim))+        -- renderBkg (rbkg2Bkg r,dim) >> return (r,dim)+      (RBkgPDF _ _ _ p _) -> +        maybe (return (r,dim)) +              (\pg -> drawBkgAndRecord (bkgPdfRender pg)) p+      (RBkgEmbedPDF _ p _) -> +        maybe (return (r,dim)) +              (\pg -> drawBkgAndRecord (bkgPdfRender pg)) p +  where +    drawBkgAndRecord rdr = do +      rdr +      case rbkg_cairosurface r of+        Nothing -> return ()+        Just sfc -> liftIO $ renderWith sfc rdr+      return (r,dim)+    bkgPdfRender pg = do        let Dim w h = dim        setSourceRGBA 1 1 1 1       rectangle 0 0 w h        fill-#ifdef POPPLER       PopplerPage.pageRender pg-#endif     -  return (r,dim)  ++ -- | renderRItem :: RItem -> Render RItem  -renderRItem itm@(RItemStroke strk) = renderStrk (strkbbx_strk strk) >> return itm+renderRItem itm@(RItemStroke strk) = renderStrk (bbxed_content strk) >> return itm renderRItem itm@(RItemImage img msfc) = do     case msfc of-    Nothing -> renderImg (imgbbx_img img)+    Nothing -> renderImg (bbxed_content img)     Just sfc -> do -      let (x,y) = (img_pos . imgbbx_img) img+      let (x,y) = (img_pos . bbxed_content) img           BBox (x1,y1) (x2,y2) = getBBox img       ix <- liftM fromIntegral (imageSurfaceGetWidth sfc)       iy <- liftM fromIntegral (imageSurfaceGetHeight sfc)-      -- clipBBox (Just (getBBox img))       save        translate x y        scale ((x2-x1)/ix) ((y2-y1)/iy)       setSourceSurface sfc 0 0        paint        restore-      -- resetClip    return itm  renderRItem itm@(RItemSVG svgbbx mrsvg) = do    case mrsvg of-    Nothing -> renderSVG (svgbbx_svg svgbbx)+    Nothing -> renderSVG (bbxed_content svgbbx)     Just rsvg -> do -      let (x,y) = (svg_pos . svgbbx_svg) svgbbx+      let (x,y) = (svg_pos . bbxed_content) svgbbx           BBox (x1,y1) (x2,y2) = getBBox svgbbx           (ix',iy') = RSVG.svgGetSize rsvg           ix = fromIntegral ix' @@ -244,12 +240,29 @@       RSVG.svgRender rsvg        restore       resetClip -       return () -   return itm +renderRItem itm@(RItemLink lnkbbx mrsvg) = do +  case mrsvg of+    Nothing -> renderLink (bbxed_content lnkbbx)+    Just rsvg -> do +      let (x,y) = (link_pos . bbxed_content) lnkbbx+          BBox (x1,y1) (x2,y2) = getBBox lnkbbx+          (ix',iy') = RSVG.svgGetSize rsvg+          ix = fromIntegral ix' +          iy = fromIntegral iy'+      clipBBox (Just (getBBox lnkbbx))+      save +      translate x y +      scale ((x2-x1)/ix) ((y2-y1)/iy)+      RSVG.svgRender rsvg +      restore+      resetClip +      return () +  return itm   + ------------ -- InBBox -- ------------@@ -259,7 +272,12 @@                   -> (RBackground,Dimension)                    -> Render (RBackground,Dimension) renderRBkg_InBBox mbbox (b,dim) = do -    case b of +    clipBBox mbbox+    renderRBkg_Buf (b,dim)+    resetClip+    return (b,dim)++{-    case b of        RBkgSmpl _ _ _ -> do          clipBBox mbbox         renderRBkg_Buf (b,dim)@@ -268,13 +286,16 @@         clipBBox mbbox         renderRBkg_Buf (b,dim)         resetClip-    return (b,dim)+      RBkgEmbedPDF _ _ _ -> do +        clipBBox mbbox+        renderRBkg_Buf (b,dim)+        resetClip -}   -- | render RLayer within BBox after hittest items renderRLayer_InBBox :: Maybe BBox -> RLayer -> Render RLayer renderRLayer_InBBox mbbox layer = do  -  clipBBox mbbox +  clipBBox (fmap (flip inflate 1) mbbox)    let hittestbbox = case mbbox of          Nothing -> NotHitted []                     :- Hitted (view gitems layer) @@ -288,7 +309,7 @@     LyBuf (Just sfc) -> do        liftIO $ renderWith sfc $ do          -- renderRLayer_InBBox mbbox lyr -        clipBBox mbbox +        clipBBox (fmap (flip inflate 1) mbbox )         setSourceRGBA 0 0 0 0          setOperator OperatorSource         paint@@ -322,6 +343,13 @@           Just sfc -> do              setSourceSurface sfc 0 0              paint +      RBkgEmbedPDF _ _ msfc -> do +        case msfc of +          Nothing -> renderRBkg (b,dim) >> return ()+          Just sfc -> do +            setSourceSurface sfc 0 0 +            paint +     return (b,dim)  -- | @@ -357,15 +385,6 @@         renderRLayer_InBBox Nothing lyr       return (set gbuffer (LyBuf (Just sfc)) lyr)        -       -      -- liftIO $ putStrLn "renderRLayer_InBBoxBuf"-         -- clipBBox mbbox    -        -- setSourceSurface sfc 0 0 -        -- paint -        -- resetClip--- -- |  updatePageBuf :: RPage -> IO RPage  updatePageBuf pg = do @@ -389,11 +408,15 @@ -- | cnstrctRHoodle :: Hoodle -> IO RHoodle cnstrctRHoodle hdl = do -  let ttl = view title hdl +  let hid = view hoodleID hdl +      ttl = view title hdl        pgs = view pages hdl-  npgs <- evalStateT (mapM cnstrctRPage_StateT pgs) Nothing -  return . set gtitle ttl . set gpages (fromList npgs) $ emptyGHoodle -    +      embeddedsrc = view embeddedPdf hdl +  mdoc <- maybe (return Nothing) (\src -> liftIO $ popplerGetDocFromDataURI src)+            embeddedsrc+  npgs <- evalStateT (mapM cnstrctRPage_StateT pgs) (Just (Context "" "" Nothing mdoc)) +  return $ GHoodle hid ttl embeddedsrc (fromList npgs)          +     -- | cnstrctRPage_StateT :: Page -> StateT (Maybe Context) IO RPage@@ -401,52 +424,16 @@   let bkg = view background pg       dim = view dimension pg        lyrs = view layers pg-  nlyrs <- liftIO $ (liftM fromList . mapM cnstrctRLayer) lyrs +  nlyrs_lst <- liftIO $ mapM cnstrctRLayer lyrs+  let nlyrs_nonemptylst = if null nlyrs_lst then (emptyRLayer,[]) else (head nlyrs_lst,tail nlyrs_lst) +      nlyrs = fromNonEmptyList nlyrs_nonemptylst    nbkg <- cnstrctRBkg_StateT dim bkg-  return . set glayers nlyrs $ emptyGPage dim nbkg +  return $ GPage dim nbkg nlyrs      -+-- | cnstrctRLayer :: Layer -> IO RLayer  cnstrctRLayer lyr = do    nitms <- (mapM cnstrctRItem . view items) lyr    return (set gitems nitms emptyRLayer)                   --- |-cnstrctRBkg_StateT :: Dimension -> Background -                   -> StateT (Maybe Context) IO RBackground-cnstrctRBkg_StateT dim@(Dim w h) bkg = do  -  let rbkg = bkg2RBkg bkg-  case rbkg of -    RBkgSmpl _c _s msfc -> do -      case msfc of -        Just _ -> return rbkg-        Nothing -> do -          sfc <- liftIO $ createImageSurface FormatARGB32 (floor w) (floor h)-          renderWith sfc $ renderBkg (bkg,dim) -          return rbkg { rbkg_cairosurface = Just sfc}-    RBkgPDF md mf pn _ _ -> do -#ifdef POPPLER-      mctxt <- get -      case mctxt of-        Nothing -> do -          case (md,mf) of -            (Just d, Just f) -> do -              mdoc <- liftIO $ popplerGetDocFromFile f-              put $ Just (Context d f mdoc)-              case mdoc of -                Just doc -> do  -                  (mpg,msfc) <- liftIO $ popplerGetPageFromDoc doc pn -                  return (rbkg {rbkg_popplerpage = mpg, rbkg_cairosurface = msfc})-                Nothing -> error "no pdf doc? in mkBkgPDF"-            _ -> return rbkg -        Just (Context _oldd _oldf olddoc) -> do -          (mpage,msfc) <- case olddoc of -            Just doc -> do -              liftIO $ popplerGetPageFromDoc doc pn-            Nothing -> return (Nothing,Nothing) -          return $ RBkgPDF md mf pn mpage msfc-#else-          return rbkg-#endif  -

@@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} --- {-# LANGUAGE ExistentialQuantification, OverloadedStrings, ---              FlexibleInstances, FlexibleContexts,  ---              TypeFamilies, CPP #-}- ----------------------------------------------------------------------------- -- | -- Module      : Graphics.Hoodle.Render.PDFBackground @@ -24,34 +20,60 @@ import           Data.Foldable (mapM_) import           Graphics.Rendering.Cairo ---#ifdef POPPLER+import qualified Data.Map as M+import           Data.ByteString.Base64  import qualified Data.ByteString.Char8 as C import           Data.Monoid import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage-#endif -- from hoodle-platform import           Data.Hoodle.BBox import           Data.Hoodle.Predefined +import           Data.Hoodle.Simple --+import           Graphics.Hoodle.Render.Type.Background+--  import Prelude hiding (mapM_)-  -  ++{-+isPopplerEnabled :: Bool   #ifdef POPPLER+isPopplerEnabled = True +#else+isPopplerEnabled = False+#endif+-} ++-- | popplerGetDocFromFile :: ByteString -> IO (Maybe Poppler.Document) popplerGetDocFromFile fp =    Poppler.documentNewFromFile      (C.unpack ("file://localhost" `mappend` fp)) Nothing -#endif -#ifdef POPPLER             +-- |+getByteStringIfEmbeddedPDF :: ByteString -> Maybe ByteString +getByteStringIfEmbeddedPDF bstr = do +    guard (C.length bstr > 30)+    let (header,dat) = C.splitAt 30 bstr +    guard (header == "data:application/x-pdf;base64,") +    either (const Nothing) return (decode dat)++-- | +popplerGetDocFromDataURI :: ByteString -> IO (Maybe Poppler.Document) +popplerGetDocFromDataURI dat = do +  let mdecoded = getByteStringIfEmbeddedPDF dat +  case mdecoded of +    Nothing -> return Nothing +    Just decoded -> do +      C.writeFile "/tmp/popplertest.pdf" decoded +      popplerGetDocFromFile "/tmp/popplertest.pdf"+++-- | popplerGetPageFromDoc :: Poppler.Document                        -> Int -- ^ page number                        -> IO (Maybe Poppler.Page, Maybe Surface) popplerGetPageFromDoc doc pn = do   -  -- n <- Poppler.documentGetNPages doc  -  -- putStrLn $ "pages : " ++ (show n)-  -- putStrLn $ "current page = " ++ show pn   pg <- Poppler.documentGetPage doc (pn-1)    (w,h) <- PopplerPage.pageGetSize pg   sfc <- createImageSurface FormatARGB32 (floor w) (floor h)@@ -61,7 +83,6 @@     fill     PopplerPage.pageRender pg   return (Just pg, Just sfc)-#endif  -- | draw ruling all  drawRuling :: Double -> Double -> ByteString -> Render () @@ -156,5 +177,64 @@     _ -> return ()       -      +-- | render background without any constraint +renderBkg :: (Background,Dimension) -> Render () +renderBkg (Background _typ col sty,Dim w h) = do +    let c = M.lookup col predefined_bkgcolor  +    case c of +      Just (r,g,b,_a) -> setSourceRGB r g b +      Nothing        -> setSourceRGB 1 1 1 +    rectangle 0 0 w h +    fill+    drawRuling w h sty+renderBkg (BackgroundPdf _ _ _ _,Dim w h) = do +    setSourceRGBA 1 1 1 1+    rectangle 0 0 w h +    fill+renderBkg (BackgroundEmbedPdf _ _,Dim w h) = do +    setSourceRGBA 1 1 1 1+    rectangle 0 0 w h +    fill++++-- | this has some bugs. need to fix +cnstrctRBkg_StateT :: Dimension -> Background +                   -> StateT (Maybe Context) IO RBackground+cnstrctRBkg_StateT dim@(Dim w h) bkg = do  +  case bkg of +    Background _t c s -> do +      sfc <- liftIO $ createImageSurface FormatARGB32 (floor w) (floor h)+      renderWith sfc $ renderBkg (bkg,dim) +      return (RBkgSmpl c s (Just sfc))+    BackgroundPdf _t md mf pn -> do +      case (md,mf) of +        (Just d, Just f) -> do +           mdoc <- liftIO $ popplerGetDocFromFile f+           put $ Just (Context d f mdoc Nothing)+           case mdoc of +             Just doc -> do  +               (mpg,msfc) <- liftIO $ popplerGetPageFromDoc doc pn +               return (RBkgPDF md f pn mpg msfc)+             Nothing -> error "error1 in cnstrctRBkg_StateT"+        _ -> do +          mctxt <- get+          case mctxt of  +            Just (Context oldd oldf olddoc _) -> do +              (mpage,msfc) <- case olddoc of +                Just doc -> do +                  liftIO $ popplerGetPageFromDoc doc pn+                Nothing -> error "error2 in cnstrctRBkg_StateT" +              return (RBkgPDF (Just oldd) oldf pn mpage msfc)+            Nothing -> error "error3 in cnstrctRBkg_StateT" +    BackgroundEmbedPdf _ pn -> do +      mctxt <- get+      case mctxt of  +        Just (Context _ _ _ mdoc) -> do +          (mpage,msfc) <- case mdoc of +            Just doc -> do +              liftIO $ popplerGetPageFromDoc doc pn+            Nothing -> error "error4 in cnstrctRBkg_StateT" +          return (RBkgEmbedPDF pn mpage msfc)+        Nothing -> error "error5 in cnstrctRBkg_StateT"  

@@ -21,7 +21,7 @@ -- * dummy rendering    renderRBkg_Dummy   -- * render in bbox using non R-structure -, renderBkg_InBBox+-- , renderBkg_InBBox -- * nopdf , renderRBkg_NoPDF -- * render only bbox (for debug purpose)@@ -45,9 +45,6 @@ import Data.Hoodle.Simple import Data.Hoodle.BBox import Data.Hoodle.Predefined --- #ifdef POPPLER--- import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage--- #endif -- from this package import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Type @@ -72,34 +69,35 @@ renderRBkg_NoPDF :: (RBackground,Dimension) -> Render () renderRBkg_NoPDF r@(RBkgSmpl _ _ _,_) = renderRBkg r >> return () renderRBkg_NoPDF (RBkgPDF _ _ _ _ _,_) = return ()+renderRBkg_NoPDF (RBkgEmbedPDF _ _ _,_) = return ()  -------------- -- BBoxOnly -- --------------  -- | render only bounding box of a StrokeBBox      -renderStrkBBx_BBoxOnly :: StrokeBBox -> Render () +renderStrkBBx_BBoxOnly :: BBoxed Stroke -> Render ()  renderStrkBBx_BBoxOnly sbbox = do  -    let s = strkbbx_strk sbbox+    let s = bbxed_content sbbox     case M.lookup (stroke_color s) predefined_pencolor of        Just (r,g,b,a) -> setSourceRGBA r g b a       Nothing -> setSourceRGBA 0 0 0 1      setSourceRGBA 0 0 0 1     setLineWidth (stroke_width s) -    let BBox (x1,y1) (x2,y2) = strkbbx_bbx sbbox+    let BBox (x1,y1) (x2,y2) = getBBox sbbox     rectangle x1 y1 (x2-x1) (y2-y1)     stroke    -- |     -renderImgBBx_BBoxOnly :: ImageBBox -> Render () +renderImgBBx_BBoxOnly :: BBoxed Image -> Render ()  renderImgBBx_BBoxOnly ibbox = do      setSourceRGBA 0 0 0 1     setLineWidth 10-    let BBox (x1,y1) (x2,y2) = imgbbx_bbx ibbox+    let BBox (x1,y1) (x2,y2) = getBBox ibbox     rectangle x1 y1 (x2-x1) (y2-y1)     stroke -renderSVGBBx_BBoxOnly :: SVGBBox -> Render () +renderSVGBBx_BBoxOnly :: BBoxed SVG -> Render ()  renderSVGBBx_BBoxOnly svg = do      setSourceRGBA 0 0 0 1     setLineWidth 10@@ -107,6 +105,14 @@     rectangle x1 y1 (x2-x1) (y2-y1)     stroke +renderLnkBBx_BBoxOnly :: BBoxed Link -> Render () +renderLnkBBx_BBoxOnly lnk = do +    setSourceRGBA 0 0 0 1+    setLineWidth 10+    let BBox (x1,y1) (x2,y2) = getBBox lnk+    rectangle x1 y1 (x2-x1) (y2-y1)+    stroke+       -- | @@ -114,6 +120,7 @@ renderRItem_BBoxOnly (RItemStroke sbbox) = renderStrkBBx_BBoxOnly sbbox renderRItem_BBoxOnly (RItemImage ibbox _) = renderImgBBx_BBoxOnly ibbox renderRItem_BBoxOnly (RItemSVG svg _) = renderSVGBBx_BBoxOnly svg+renderRItem_BBoxOnly (RItemLink lnk _) = renderLnkBBx_BBoxOnly lnk   -- | 

@@ -48,8 +48,8 @@   cairoRender = passarg renderStrk   -- | -instance Renderable StrokeBBox where-  cairoRender = passarg (renderStrk . strkbbx_strk)+instance Renderable (BBoxed Stroke) where+  cairoRender = passarg (renderStrk . bbxed_content)    -- |  instance Renderable RLayer where@@ -74,8 +74,8 @@ data StrokeBBoxOption = DrawFull | DrawBoxOnly   -- | -instance RenderOptionable StrokeBBox where-  type RenderOption StrokeBBox = StrokeBBoxOption+instance RenderOptionable (BBoxed Stroke) where+  type RenderOption (BBoxed Stroke) = StrokeBBoxOption   cairoRenderOption DrawFull = cairoRender    cairoRenderOption DrawBoxOnly = passarg renderStrkBBx_BBoxOnly   

@@ -30,9 +30,9 @@ import Prelude hiding (fst,snd,curry,uncurry,mapM_,concatMap)  -- | -renderStrkHltd :: StrokeBBox -> Render ()+renderStrkHltd :: BBoxed Stroke -> Render () renderStrkHltd sbbox = do -    let s = strkbbx_strk sbbox +    let s = bbxed_content sbbox      case M.lookup (stroke_color s) predefined_pencolor of        Just (r,g,b,a) -> setSourceRGBA r g b a       Nothing -> setSourceRGBA 0 0 0 1 @@ -55,20 +55,36 @@         drawVWStrokeCurve d              fill     + -- | render items highlighted  renderRItemHltd :: RItem -> Render () renderRItemHltd (RItemStroke strk) = renderStrkHltd strk-renderRItemHltd (RItemImage img _) = do -  setSourceRGBA 0 0 0 1+renderRItemHltd (RItemImage img _) = renderBBoxHltd img+{-  setSourceRGBA 0 0 0 1   setLineWidth 10 -  let BBox (x1,y1) (x2,y2) = imgbbx_bbx img+  let BBox (x1,y1) (x2,y2) = getBBox img   rectangle x1 y1 (x2-x1) (y2-y1)-  stroke-renderRItemHltd (RItemSVG svg _) = do -  setSourceRGBA 0 0 0 1+  stroke -}+renderRItemHltd (RItemSVG svg _) = renderBBoxHltd svg +{-  setSourceRGBA 0 0 0 1   setLineWidth 10    let BBox (x1,y1) (x2,y2) = getBBox svg   rectangle x1 y1 (x2-x1) (y2-y1)-  stroke+  stroke -}+renderRItemHltd (RItemLink lnk _) = renderBBoxHltd lnk+{-  setSourceRGBA 0 0 0 1+  setLineWidth 10 +  let BBox (x1,y1) (x2,y2) = getBBox lnk+  rectangle x1 y1 (x2-x1) (y2-y1)+  stroke -} ++-- |+renderBBoxHltd :: (GetBBoxable a) => a -> Render () +renderBBoxHltd x = do +  setSourceRGBA 0 0 0 1+  setLineWidth 10 +  let BBox (x1,y1) (x2,y2) = getBBox x+  rectangle x1 y1 (x2-x1) (y2-y1)+  stroke 

@@ -19,8 +19,10 @@  import           Control.Applicative import           Control.Monad +import           Control.Monad.Identity  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8+-- import qualified Data.ByteString.Lazy as LB import           Data.ByteString.Base64  import           Graphics.GD.ByteString import           Graphics.Rendering.Cairo@@ -28,17 +30,18 @@ import           System.Directory import           System.FilePath  -- from hoodle-platform -import Data.Hoodle.BBox -import Data.Hoodle.Simple+import           Data.Hoodle.BBox +import           Data.Hoodle.Simple+import           Hoodle.Util.Process  -- from this package import Graphics.Hoodle.Render.Type.Item    -- | construct renderable item  cnstrctRItem :: Item -> IO RItem -cnstrctRItem (ItemStroke strk) = return (RItemStroke (mkStrokeBBox strk))+cnstrctRItem (ItemStroke strk) = return (RItemStroke (runIdentity (makeBBoxed strk))) cnstrctRItem (ItemImage img) = do -    let imgbbx = mkImageBBox img+    let imgbbx = runIdentity (makeBBoxed img)         src = img_src img         embed = getByteStringIfEmbeddedPNG src      case embed of         @@ -49,19 +52,34 @@         let filesrc = C8.unpack (img_src img)             filesrcext = takeExtension filesrc              imgaction -              | filesrcext == ".PNG" || filesrcext == ".png" = -                  Just <$> imageSurfaceCreateFromPNG filesrc-              | filesrcext == ".JPG" || filesrcext == ".jpg" = -                  Just <$> getJPGandCreateSurface filesrc +              | filesrcext == ".PNG" || filesrcext == ".png" = do +                  b <- doesFileExist filesrc +                  if b then Just <$> imageSurfaceCreateFromPNG filesrc+                       else return Nothing +              | filesrcext == ".JPG" || filesrcext == ".jpg" = do +                  b <- doesFileExist filesrc +                  if b then Just <$> getJPGandCreateSurface filesrc +                       else return Nothing                | otherwise = return Nothing          msfc <- imgaction         return (RItemImage imgbbx msfc) cnstrctRItem (ItemSVG svg@(SVG _ _ bstr _ _)) = do      let str = C8.unpack bstr -        svgbbx = mkSVGBBox svg+        svgbbx = runIdentity (makeBBoxed svg)     rsvg <- RSVG.svgNewFromString str     return (RItemSVG svgbbx (Just rsvg))+cnstrctRItem (ItemLink lnk@(Link _ _ _ _ _ bstr _ _)) = do +    let str = C8.unpack bstr +        lnkbbx = runIdentity (makeBBoxed lnk)+    rsvg <- RSVG.svgNewFromString str+    return (RItemLink lnkbbx (Just rsvg))+cnstrctRItem (ItemLink lnk@(LinkDocID _ _ _ _ _ bstr _ _)) = do +    let str = C8.unpack bstr +        lnkbbx = runIdentity (makeBBoxed lnk)+    rsvg <- RSVG.svgNewFromString str+    return (RItemLink lnkbbx (Just rsvg))     + -- | get embedded png image. If not, just give me nothing.  getByteStringIfEmbeddedPNG :: C8.ByteString -> Maybe C8.ByteString  getByteStringIfEmbeddedPNG bstr = do @@ -82,7 +100,10 @@ -- |  saveTempPNGToCreateSurface :: C8.ByteString -> IO Surface saveTempPNGToCreateSurface bstr = do +    pipeActionWith (B.writeFile "/dev/stdout" bstr) imageSurfaceCreateFromPNG ++{-     tdir <- getTemporaryDirectory      let tfile = tdir </> "temp.png"-    B.writeFile tfile bstr      imageSurfaceCreateFromPNG tfile +-}

@@ -17,9 +17,7 @@  import           Data.ByteString  import           Graphics.Rendering.Cairo-#ifdef POPPLER import qualified Graphics.UI.Gtk.Poppler.Document as Poppler-#endif -- from hoodle-platform import           Data.Hoodle.BBox import           Data.Hoodle.Simple @@ -32,11 +30,8 @@ -- |  data Context = Context { ctxt_domain :: ByteString                        , ctxt_filename :: ByteString -#ifdef POPPLER                        , ctxt_doc :: Maybe Poppler.Document-#else-                       , ctxt_doc :: Maybe ()-#endif +                       , ctxt_embeddeddoc :: Maybe Poppler.Document                        }  -- |@@ -47,15 +42,16 @@                    , rbkg_cairosurface :: Maybe Surface }                  | RBkgPDF                     { rbkg_domain :: Maybe ByteString-                   , rbkg_filename :: Maybe ByteString+                   , rbkg_filename :: ByteString                    , rbkg_pageno :: Int -#ifdef POPPLER                    , rbkg_popplerpage :: Maybe Poppler.Page -#else    -                   , rbkg_popplerpage :: Maybe ()-#endif                    , rbkg_cairosurface :: Maybe Surface } +                 | RBkgEmbedPDF+                   { rbkg_pageno :: Int+                   , rbkg_popplerpage :: Maybe Poppler.Page +                   , rbkg_cairosurface :: Maybe Surface }  + isRBkgSmpl :: RBackground -> Bool  isRBkgSmpl (RBkgSmpl _ _ _) = True  isRBkgSmpl _ = False @@ -68,9 +64,9 @@ -- | rbkg2Bkg :: RBackground -> Background  rbkg2Bkg (RBkgSmpl c s _) = Background "solid" c s -rbkg2Bkg (RBkgPDF d f n _ _ ) = BackgroundPdf "pdf" d f n +rbkg2Bkg (RBkgPDF d f n _ _ ) = BackgroundPdf "pdf" d (Just f) n +rbkg2Bkg (RBkgEmbedPDF n _ _) = BackgroundEmbedPdf "embedpdf" n --- |-bkg2RBkg :: Background -> RBackground-bkg2RBkg (Background _t c s) = RBkgSmpl c s Nothing-bkg2RBkg (BackgroundPdf _t md mf pn) = RBkgPDF md mf pn Nothing Nothing+++

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveFunctor #-}+ ----------------------------------------------------------------------------- -- | -- Module      : Graphics.Hoodle.Render.Type.HitTest @@ -14,7 +16,10 @@  module Graphics.Hoodle.Render.Type.HitTest where ++--  import Data.Hoodle.BBox+import Data.Hoodle.Simple --  import Graphics.Hoodle.Render.Type.Item  --@@ -28,14 +33,14 @@  -- |  newtype NotHitted a = NotHitted { unNotHitted :: [a] } -                    deriving (Show)+                    deriving (Show,Functor)  -- |  newtype Hitted a = Hitted { unHitted :: [a] } -                   deriving (Show)+                   deriving (Show,Functor)  -- | -type StrokeHitted = AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox) +type StrokeHitted = AlterList (NotHitted (BBoxed Stroke)) (Hitted (BBoxed Stroke))  -- |  type RItemHitted = AlterList (NotHitted RItem) (Hitted RItem) 

@@ -73,7 +73,9 @@  -- | project to simple Hoodle out of RHoodle  rHoodle2Hoodle :: RHoodle -> Hoodle -rHoodle2Hoodle = Hoodle <$> view gtitle +rHoodle2Hoodle = Hoodle <$> view ghoodleID+                        <*> view gtitle +                        <*> view gembeddedpdf                         <*> IM.elems . fmap rPage2Page . view gpages  

@@ -22,19 +22,22 @@ import Data.Hoodle.BBox  import Data.Hoodle.Simple -data RItem = RItemStroke StrokeBBox -           | RItemImage ImageBBox (Maybe Surface)-           | RItemSVG SVGBBox (Maybe RSVG.SVG)+data RItem = RItemStroke (BBoxed Stroke)+           | RItemImage (BBoxed Image) (Maybe Surface)+           | RItemSVG (BBoxed SVG) (Maybe RSVG.SVG)+           | RItemLink (BBoxed Link) (Maybe RSVG.SVG) -instance BBoxable RItem where+instance GetBBoxable RItem where   getBBox (RItemStroke strk) = getBBox strk   getBBox (RItemImage img _) = getBBox img    getBBox (RItemSVG svg _) = getBBox svg +  getBBox (RItemLink lnk _) = getBBox lnk  instance Show RItem where   show (RItemStroke strk) = "RItemStroke " ++ show strk   show (RItemImage img _) = "RItemImage " ++ show img    show (RItemSVG svg _) = "RItemSVG " ++ show svg+  show (RItemLink lnk _) = "RItemLink " ++ show lnk  -- |  isStrkInRItem :: RItem -> Bool @@ -51,30 +54,36 @@ isSVGInRItem (RItemSVG _ _) = True isSVGInRItem _ = False +-- | +isLinkInRItem :: RItem -> Bool +isLinkInRItem (RItemLink _ _) = True +isLinkInRItem _ = False + -- | -findStrkInRItem :: RItem -> Maybe StrokeBBox +findStrkInRItem :: RItem -> Maybe (BBoxed Stroke) findStrkInRItem (RItemStroke strk) = Just strk findStrkInRItem _ = Nothing   -- | -findImgInRItem :: RItem -> Maybe ImageBBox+findImgInRItem :: RItem -> Maybe (BBoxed Image) findImgInRItem (RItemImage img _ ) = Just img  findImgInRItem _ = Nothing    -- | -findSVGInRItem :: RItem -> Maybe SVGBBox+findSVGInRItem :: RItem -> Maybe (BBoxed SVG) findSVGInRItem (RItemSVG svg _) = Just svg  findSVGInRItem _ = Nothing   - -- | rItem2Item :: RItem -> Item -rItem2Item (RItemStroke strk) = (ItemStroke . strkbbx_strk) strk-rItem2Item (RItemImage img _) = (ItemImage . imgbbx_img) img-rItem2Item (RItemSVG svg _) = (ItemSVG. svgbbx_svg) svg+rItem2Item (RItemStroke strk) = (ItemStroke . bbxed_content) strk+rItem2Item (RItemImage img _) = (ItemImage . bbxed_content) img+rItem2Item (RItemSVG svg _) = (ItemSVG . bbxed_content) svg+rItem2Item (RItemLink lnk _) = (ItemLink . bbxed_content) lnk+  {- -- | 

@@ -15,7 +15,6 @@ module Graphics.Hoodle.Render.Type.Select where  -- from other packages-import Control.Compose import Control.Lens  import Data.IntMap hiding (map, fromList) -- from hoodle-platform @@ -84,28 +83,17 @@ hPage2RPage p =    let HLayersF s others = view glayers p        s' = hLayer2RLayer s-      normalizedothers = case others of   -        NoSelect [] -> error "something wrong in hPage2RPage" -        NoSelect (x:xs) -> Select (fromList (x:xs))-        Select (O (Nothing)) -> error "something wrong in hPage2RPage"-        Select (O (Just _)) -> others -      Select (O (Just sz)) = normalizedothers -  in GPage (view gdimension p) (view gbackground p) (Select . O . Just $ replace s' sz)+  in GPage (view gdimension p) (view gbackground p) (replace s' others)   -- |  mkHPage :: RPage -> HPage mkHPage p = -  let normalizedothers = case (view glayers p) of -        NoSelect [] -> error "something wrong in mkHPage" -        NoSelect (x:xs) -> Select (fromList (x:xs))-        Select (O (Nothing)) -> error "something wrong in mkHPage"-        others@(Select (O (Just _))) -> others -      Select (O (Just sz)) = normalizedothers +  let sz = view glayers p        curr  = current sz        currtemp = GLayer (view gbuffer curr) (TEitherAlterHitted . Left . view gitems $ curr)   in  GPage (view gdimension p) (view gbackground p) -            (HLayersF currtemp normalizedothers)+            (HLayersF currtemp sz)   

@@ -115,21 +115,21 @@   -- | -hltHittedByBBox :: (BBoxable a) => +hltHittedByBBox :: (GetBBoxable a) =>                     BBox  -- ^ test bounding box                 -> [a] -- ^ items to test                 -> AlterList (NotHitted a) (Hitted a) hltHittedByBBox b = hltFilteredBy (do2BBoxIntersect b . getBBox)   -- | -hltEmbeddedByBBox :: (BBoxable a) =>+hltEmbeddedByBBox :: (GetBBoxable a) =>                      BBox                    -> [a]                    -> AlterList (NotHitted a) (Hitted a) hltEmbeddedByBBox b = hltFilteredBy (isBBox2InBBox1 b . getBBox)  -- | only check if a line and bbox of item overlapped -hltHittedByLineRough :: (BBoxable a) => +hltHittedByLineRough :: (GetBBoxable a) =>                          ((Double,Double),(Double,Double)) -- ^ line                       -> [a] -- ^ items to test                      -> AlterList (NotHitted a) (Hitted a)@@ -144,7 +144,7 @@                            -> State Bool RItemHitted                               -- (AlterList (NotHitted RItem) (Hitted RItem)) hltItmsHittedByLine_StateT line = hltFilteredBy_StateT test  -  where test (RItemStroke strk) = (doesLineHitStrk line . strkbbx_strk) strk+  where test (RItemStroke strk) = (doesLineHitStrk line . bbxed_content) strk         test _ = False     -- |@@ -161,78 +161,8 @@   ------------------------------------------------- stroke filtering functions as AlterList ------------------------------------------------- -{-  --- | previously mkHitTestALState-hltStrksFilteredBy_StateT :: (StrokeBBox -> Bool)  -- ^ hit test condition-                          -> [StrokeBBox]          -- ^ strokes to test -                          -> State Bool (AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox))-hltStrksFilteredBy_StateT test strs = do -    let (nhit,rest) = break test  strs-        (hit,rest') = break (not.test) rest -    modify (|| (not.null) hit) -    if null rest' -      then return (NotHitted nhit :- Hitted hit :- NotHitted [] :- Empty)-      else return (NotHitted nhit :- Hitted hit :- hltStrksFilteredBy test rest')---- | highlight strokes filtered by a condition. ---   previously mkHitTestAL-hltStrksFilteredBy :: (StrokeBBox -> Bool)  -- ^ hit test condition-                   -> [StrokeBBox]          -- ^ strokes to test -                   -> AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox)-hltStrksFilteredBy test strs = evalState (hltStrksFilteredBy_StateT test strs) False--- -- | -hltStrksHittedByBBox :: BBox  -- ^ test bounding box-                     -> [StrokeBBox] -- ^ strokes to test-                     -> AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox)-hltStrksHittedByBBox b = hltStrksFilteredBy (do2BBoxIntersect b . strkbbx_bbx) ---- | previously, mkHitTestInsideBBox-hltStrksEmbeddedByBBox :: BBox -                       -> [StrokeBBox] -                       -> AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox)-hltStrksEmbeddedByBBox b = hltStrksFilteredBy (isBBox2InBBox1 b . strkbbx_bbx)---- | only check if a line and bbox of strokebbox overlapped ---   previously, mkHitTestBBox-hltStrksHittedByLineRough :: ((Double,Double),(Double,Double)) -- ^ line -                          -> [StrokeBBox]                      -- ^ strokes to test-                          -> AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox)-hltStrksHittedByLineRough (p1,p2) = hltStrksFilteredBy boxhittest -  where boxhittest s = isPointInBBox (strkbbx_bbx s) p1-                       || isPointInBBox (strkbbx_bbx s) p2------ |-mkHitTestStroke :: ((Double,Double),(Double,Double))-                -> [StrokeBBox]-                -> State Bool (AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox))-mkHitTestStroke line = hltStrksFilteredBy_StateT (doesLineHitStrk line . strkbbx_strk)-  ----- |-hitTestStrokes :: ((Double,Double),(Double,Double))-               -> AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox)-               -> State Bool (AlterList (NotHitted StrokeBBox) StrokeHitted)-hitTestStrokes _ Empty = error "something is wrong, invariant broken"-hitTestStrokes _ (n:-Empty) = return (n:-Empty)-hitTestStrokes line (n:-h:-rest) = do -  h' <- mkHitTestStroke line (unHitted h)-  (n:-) . (h':-) <$> hitTestStrokes line rest---}----- | -elimHitted :: (BBoxable a) => +elimHitted :: (GetBBoxable a) =>                AlterList (NotHitted a) (Hitted a) -> State (Maybe BBox) [a] elimHitted Empty = error "something wrong in elimHitted" elimHitted (n:-Empty) = return (unNotHitted n)@@ -252,7 +182,7 @@   = Just (BBox (min x1 x3, min y1 y3) (max x2 x4,max y2 y4))        -- | -getTotalBBox :: (BBoxable a) => [a] -> Maybe BBox +getTotalBBox :: (GetBBoxable a) => [a] -> Maybe BBox  getTotalBBox = foldl f Nothing    where f acc = merge acc . Just . getBBox 

@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Util.Process+-- Copyright   : (c) 2013 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Util.Process where++import Control.Concurrent+import Control.Monad+import Control.Monad.Loops +import qualified Data.ByteString.Lazy as B+-- import Data.Monoid+-- import Data.UUID+import Data.UUID.V4 +import System.Directory+import System.FilePath+import System.IO+-- import System.IO.MMap+import System.Posix.Files+-- import System.Posix.Files.ByteString +import System.Posix.IO+import System.Posix.Process ++-- | +checkPipe :: FilePath -> IO ()+checkPipe fp = untilM_ (threadDelay 10000) (fileExist fp) +++-- | +mkTmpFileName :: IO FilePath +mkTmpFileName = do+  tdir <- getTemporaryDirectory +  tuuid <- nextRandom+  return $ tdir </> show tuuid <.> "fifo"++-- | +existThenRemove :: FilePath -> IO () +existThenRemove fp = fileExist fp >>= \b -> when b (removeLink fp) ++-- |+pipeAction :: IO () -> (B.ByteString -> IO a) -> IO a +pipeAction sender receiver = pipeActionWith sender (receiver <=< B.readFile)+++{-  filename <- mkTmpFileName +  existThenRemove filename +  createNamedPipe filename (unionFileModes ownerReadMode ownerWriteMode)+  forkProcess $ do  +    fd <- openFd filename WriteOnly Nothing defaultFileFlags+    dupTo fd stdOutput +    closeFd fd+    sender +    hFlush stdout +  r <- receiver =<< B.readFile filename << checkPipe filename +  removeLink filename  +  return r +-}++-- |+pipeActionWith :: IO () -> (FilePath -> IO a) -> IO a +pipeActionWith sender receiverf = do +  filename <- mkTmpFileName +  existThenRemove filename +  createNamedPipe filename (unionFileModes ownerReadMode ownerWriteMode)+  forkProcess $ do  +    fd <- openFd filename WriteOnly Nothing defaultFileFlags+    dupTo fd stdOutput +    closeFd fd+    sender +    hFlush stdout +  r <- checkPipe filename >> receiverf filename  +  removeLink filename  +  return r ++{-+-- | +pipeActionSystem :: String -> (B.ByteString -> IO a) -> IO a +pipeActionSystem sendercmd receiver = do +  filename <- mkTmpFileName +  existThenRemove filename +  createNamedPipe filename (unionFileModes ownerReadMode ownerWriteMode)+-}