hoodle-render (empty) → 0.1
raw patch · 18 files changed
+1864/−0 lines, 18 filesdep +TypeComposedep +basedep +bytestringsetup-changed
Dependencies added: TypeCompose, base, bytestring, cairo, containers, hoodle-types, lens, mtl, poppler, strict
Files
- CHANGES +10/−0
- LICENSE +25/−0
- Setup.lhs +10/−0
- hoodle-render.cabal +81/−0
- src/Graphics/Hoodle/Render.hs +483/−0
- src/Graphics/Hoodle/Render/Background.hs +161/−0
- src/Graphics/Hoodle/Render/Generic.hs +181/−0
- src/Graphics/Hoodle/Render/Highlight.hs +75/−0
- src/Graphics/Hoodle/Render/Item.hs +35/−0
- src/Graphics/Hoodle/Render/Primitive.hs +60/−0
- src/Graphics/Hoodle/Render/Type.hs +27/−0
- src/Graphics/Hoodle/Render/Type/Background.hs +72/−0
- src/Graphics/Hoodle/Render/Type/HitTest.hs +81/−0
- src/Graphics/Hoodle/Render/Type/Hoodle.hs +89/−0
- src/Graphics/Hoodle/Render/Type/Item.hs +64/−0
- src/Graphics/Hoodle/Render/Type/Select.hs +112/−0
- src/Graphics/Hoodle/Render/Util.hs +40/−0
- src/Graphics/Hoodle/Render/Util/HitTest.hs +258/−0
+ CHANGES view
@@ -0,0 +1,10 @@+0.2: 12 Dec 2011+ * First public release+0.3: 18 Dec 2011 + * Rename modules and make compatible with new xournal-types package+0.4: 25 Dec 2011+ * Double buffer support+0.5: 15 Jan 2012+ * ZipperSelect support+0.6: 12 Feb 2012+ * Variable width support
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010-2011, Ian-Woo Kim. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,10 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> import Distribution.PackageDescription+> --import System.Process+> main = defaultMain+> --main = defaultMainWithHooks testUserHooks+> --testUserHooks = simpleUserHooks { +> -- preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo+> -- }
+ hoodle-render.cabal view
@@ -0,0 +1,81 @@+Name: hoodle-render+Version: 0.1+Synopsis: Hoodle file renderer+Description: Rendering library using cairo for hoodle file format+License: BSD3+License-file: LICENSE+Author: Ian-Woo Kim+Maintainer: Ian-Woo Kim <ianwookim@gmail.com>+Category: Graphics+Build-Type: Simple+Cabal-Version: >= 1.8+data-files: CHANGES+Source-repository head+ type: git+ location: http://www.github.com/wavewave/hoodle-render++Flag Poppler+ Description: Enable poppler support+ Default: False++Library+ hs-source-dirs: src+ ghc-options: -Wall -fno-warn-orphans -funbox-strict-fields -fno-warn-unused-do-bind+ ghc-prof-options: -caf-all -auto-all++ if flag(poppler)+ Build-Depends: base == 4.*, + mtl == 2.*, + containers == 0.4.*, + cairo == 0.12.*, + strict == 0.3.*, + bytestring == 0.9.*,+ poppler == 0.12.*, + lens >= 2.4 && < 2.7, + hoodle-types >= 0.0.999 && < 0.2,+ TypeCompose == 0.9.*+ else+ Build-Depends: base == 4.*, + mtl == 2.*, + containers == 0.4.*, + cairo == 0.12.*, + strict == 0.3.*, + bytestring == 0.9.*,+ lens >= 2.4 && < 2.7, + hoodle-types >= 0.0.999 && < 0.2,+ TypeCompose == 0.9.*+++ Exposed-Modules: + Graphics.Hoodle.Render + Graphics.Hoodle.Render.Background+ Graphics.Hoodle.Render.Generic+ Graphics.Hoodle.Render.Highlight+ Graphics.Hoodle.Render.Item + Graphics.Hoodle.Render.Primitive+ Graphics.Hoodle.Render.Type + Graphics.Hoodle.Render.Type.Background+ Graphics.Hoodle.Render.Type.HitTest+ Graphics.Hoodle.Render.Type.Hoodle+ Graphics.Hoodle.Render.Type.Item+ Graphics.Hoodle.Render.Type.Select+ Graphics.Hoodle.Render.Util+ Graphics.Hoodle.Render.Util.HitTest+++ if flag(poppler)+ cpp-options: -DPOPPLER+ ++ -- Graphics.Hoodle.Render.SimpleNew + -- Graphics.Hoodle.Render.BBox+ -- Graphics.Hoodle.Render.PDFBackground+ -- Graphics.Hoodle.Render.BBoxMapPDF+ -- Graphics.Hoodle.Render.BBoxMapPDFImg+ -- Graphics.Hoodle.Render.Type+ -- Graphics.Hoodle.Render.Type.BBoxMapPDFImg+ -- Graphics.Hoodle.Render.Type.Select+ -- Graphics.Hoodle.Render.BBoxOnly+ -- Graphics.Hoodle.Render.InBBox+ -- Graphics.Hoodle.Render.Item+ -- Graphics.Hoodle.Render.Simple
+ src/Graphics/Hoodle/Render.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- collection of rendering routine +--+-----------------------------------------------------------------------------+++module Graphics.Hoodle.Render +( +-- * dummy rendering + renderRBkg_Dummy +-- * simple rendering using non-R-structure +, renderStrk+, renderImg+, renderBkg+, renderItem +, renderPage+-- * render in bbox using non R-structure +, renderBkg_InBBox++-- * simple rendering using R-structure +, renderRBkg+, renderRItem +-- * nopdf+, renderRBkg_NoPDF++-- * render in bbox+, renderRLayer_InBBox+, renderRBkg_InBBox ++-- * render only bbox (for debug purpose)+, renderStrkBBx_BBoxOnly+, renderImgBBx_BBoxOnly+, renderRItem_BBoxOnly+, renderRLayer_BBoxOnly+, renderRPage_BBoxOnly++-- * render using buf +, renderRBkg_Buf+, renderRLayer_InBBoxBuf++-- * buffer update +, updateLayerBuf+, updatePageBuf +, updateHoodleBuf +-- * construct R-structure from non-R-structure +, cnstrctRLayer+, cnstrctRBkg_StateT+, cnstrctRPage_StateT+, cnstrctRHoodle + +) where++import Control.Lens +import Control.Monad.State hiding (mapM,mapM_)+import Data.Foldable+import Data.Traversable (mapM)+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 qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage+#endif+-- from this package+-- import Graphics.Hoodle.Render.Simple +import Graphics.Hoodle.Render.Background +import Graphics.Hoodle.Render.Item +import Graphics.Hoodle.Render.Primitive+import Graphics.Hoodle.Render.Type +import Graphics.Hoodle.Render.Type.HitTest+import Graphics.Hoodle.Render.Util +import Graphics.Hoodle.Render.Util.HitTest +-- +import Prelude hiding (curry,uncurry,mapM,mapM_,concatMap)+++----- +-- Dummy (for testing) +-----++renderRBkg_Dummy :: (RBackground,Dimension) -> Render () +renderRBkg_Dummy (_,Dim w h) = do + setSourceRGBA 1 1 1 1+ rectangle 0 0 w h + fill ++-----+-- simple +--- ++-- | render stroke +renderStrk :: Stroke -> Render ()+renderStrk s@(Stroke _ _ w d) = do + let opacity = if stroke_tool s == "highlighter" + then predefined_highlighter_opacity+ else 1.0+ case M.lookup (stroke_color s) predefined_pencolor of+ Just (r,g,b,a) -> setSourceRGBA r g b (a*opacity) + Nothing -> setSourceRGBA 0 0 0 1+ setLineWidth w+ setLineCap LineCapRound+ setLineJoin LineJoinRound+ drawStrokeCurve d+ stroke+renderStrk s@(VWStroke _ _ d) = do + let opacity = if stroke_tool s == "highlighter" + then predefined_highlighter_opacity+ else 1.0+ case M.lookup (stroke_color s) predefined_pencolor of+ Just (r,g,b,a) -> setSourceRGBA r g b (a*opacity) + Nothing -> setSourceRGBA 0 0 0 1+ setFillRule FillRuleWinding+ drawVWStrokeCurve d+ fill ++-- | render image +renderImg :: Image -> Render () +renderImg (Image _ (x,y) (Dim w h)) = do + setSourceRGBA 0 0 0 1+ setLineWidth 10+ rectangle x y w h+ stroke++-- | render item +renderItem :: Item -> Render () +renderItem (ItemStroke strk) = renderStrk strk+renderItem (ItemImage img) = renderImg img++-- | 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+++-- |+renderPage :: Page -> Render ()+renderPage page = do + renderBkg (view background page,view dimension page)+ setLineCap LineCapRound+ setLineJoin LineJoinRound+ 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 ()+renderRBkg r@(RBkgSmpl _ _ _,dim) = renderBkg (rbkg2Bkg (fst r),dim)+renderRBkg (RBkgPDF _ _ _ p _,dim) = do+ case p of + Nothing -> return () + Just pg -> do + let Dim w h = dim + setSourceRGBA 1 1 1 1+ rectangle 0 0 w h + fill+#ifdef POPPLER+ PopplerPage.pageRender pg+#endif ++-- |+renderRItem :: RItem -> Render () +renderRItem (RItemStroke strk) = renderStrk (strkbbx_strk strk)+renderRItem (RItemImage img msfc) = do + case msfc of+ Nothing -> renderImg (imgbbx_img img)+ Just sfc -> do + let (x,y) = (img_pos . imgbbx_img) 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 + + -- renderImg (imgbbx_img img) ++--------------+-- BBoxOnly --+--------------++-- | render only bounding box of a StrokeBBox +renderStrkBBx_BBoxOnly :: StrokeBBox -> Render () +renderStrkBBx_BBoxOnly sbbox = do + let s = strkbbx_strk 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+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke+ +-- | +renderImgBBx_BBoxOnly :: ImageBBox -> Render () +renderImgBBx_BBoxOnly ibbox = do + setSourceRGBA 0 0 0 1+ setLineWidth 10+ let BBox (x1,y1) (x2,y2) = imgbbx_bbx ibbox+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke+ ++-- | +renderRItem_BBoxOnly :: RItem -> Render () +renderRItem_BBoxOnly (RItemStroke sbbox) = renderStrkBBx_BBoxOnly sbbox+renderRItem_BBoxOnly (RItemImage ibbox _) = renderImgBBx_BBoxOnly ibbox+++-- | +renderRLayer_BBoxOnly :: RLayer -> Render ()+renderRLayer_BBoxOnly = mapM_ renderRItem_BBoxOnly . view gitems++ + -- mapM_ renderStrkBBx_BBoxOnly . view gstrokes +++++ +-- | render only bounding box of a StrokeBBox +renderRPage_BBoxOnly :: RPage -> Render () +renderRPage_BBoxOnly page = do+ let dim = view gdimension page+ bkg = view gbackground page + lyrs = view glayers page+ -- cairoDrawBackground (toPage id page)+ renderRBkg_NoPDF (bkg,dim)+ mapM_ renderRLayer_BBoxOnly lyrs++-----------+-- NoPDF -- +-----------++-- | render background without pdf +renderRBkg_NoPDF :: (RBackground,Dimension) -> Render ()+renderRBkg_NoPDF r@(RBkgSmpl _ _ _,_) = renderRBkg r+renderRBkg_NoPDF (RBkgPDF _ _ _ _ _,_) = return ()+++------------+-- InBBox --+------------++-- | background drawing in bbox +renderRBkg_InBBox :: Maybe BBox -> (RBackground,Dimension) -> Render ()+renderRBkg_InBBox mbbox (b,dim) = do + case b of + RBkgSmpl _ _ _ -> do + clipBBox mbbox+ renderRBkg_Buf (b,dim)+ resetClip+ RBkgPDF _ _ _ _ _ -> do + clipBBox mbbox+ renderRBkg_Buf (b,dim)+ resetClip+++-- | render RLayer within BBox after hittest items+renderRLayer_InBBox :: Maybe BBox -> RLayer -> Render () +renderRLayer_InBBox mbbox layer = do + clipBBox mbbox + let hittestbbox = case mbbox of + Nothing -> NotHitted [] + :- Hitted (view gitems layer) + :- Empty + Just bbox -> (hltHittedByBBox bbox . view gitems) layer+ (mapM_ renderRItem . concatMap unHitted . getB) hittestbbox+ resetClip+++-----------------------+-- draw using buffer -- +-----------------------++-- | Background rendering using buffer+renderRBkg_Buf :: (RBackground,Dimension) -> Render ()+renderRBkg_Buf (b,dim) = do + case b of + RBkgSmpl _ _ msfc -> do + case msfc of + Nothing -> renderRBkg (b,dim)+ Just sfc -> do + setSourceSurface sfc 0 0 + -- setOperator OperatorSource+ -- setAntialias AntialiasNone+ paint + RBkgPDF _ _ _ _ msfc -> do + case msfc of + Nothing -> renderRBkg (b,dim)+ Just sfc -> do + setSourceSurface sfc 0 0 + -- setOperator OperatorSource+ -- setAntialias AntialiasNone+ paint ++-- | +renderRLayer_InBBoxBuf :: Maybe BBox -> RLayer -> Render ()+renderRLayer_InBBoxBuf mbbox lyr = do+ case view gbuffer lyr of + LyBuf (Just sfc) -> do clipBBox mbbox+ setSourceSurface sfc 0 0 + -- setOperator OperatorSource+ -- setAntialias AntialiasNone+ paint + resetClip + _ -> renderRLayer_InBBox mbbox lyr +++-------------------+-- update buffer+-------------------++-- | +updateLayerBuf :: Maybe BBox -> RLayer -> IO RLayer+updateLayerBuf mbbox lyr = do + case view gbuffer lyr of + LyBuf (Just sfc) -> do + renderWith sfc $ do + clearBBox mbbox + renderRLayer_InBBox mbbox lyr + return lyr+ _ -> return lyr+++-- | +updatePageBuf :: RPage -> IO RPage +updatePageBuf pg = do + let dim = view gdimension pg+ mbbox = Just . dimToBBox $ dim + nlyrs <- mapM (updateLayerBuf mbbox) . view glayers $ pg + return (set glayers nlyrs pg)++-- | +updateHoodleBuf :: RHoodle -> IO RHoodle +updateHoodleBuf hdl = do + let pgs = view gpages hdl + npgs <- mapM updatePageBuf pgs+ return . set gpages npgs $ hdl++-------+-- smart constructor for R hoodle structures+-------+++-- |+cnstrctRHoodle :: Hoodle -> IO RHoodle+cnstrctRHoodle hdl = do + let ttl = view title hdl + pgs = view pages hdl+ npgs <- evalStateT (mapM cnstrctRPage_StateT pgs) Nothing + return . set gtitle ttl . set gpages (fromList npgs) $ emptyGHoodle + +{- +-- |+mkAllTPageBBoxMapPDF :: [Page] -> IO [TPageBBoxMapPDF]+mkAllTPageBBoxMapPDF pgs = evalStateT (mapM mkPagePDF pgs) Nothing +-}++-- |+cnstrctRPage_StateT :: Page -> StateT (Maybe Context) IO RPage+cnstrctRPage_StateT pg = do + let bkg = view background pg+ dim = view dimension pg + lyrs = view layers pg+ nlyrs <- liftIO $ (liftM fromList . mapM cnstrctRLayer) lyrs + nbkg <- cnstrctRBkg_StateT dim bkg+ return . set glayers nlyrs $ emptyGPage dim nbkg + ++cnstrctRLayer :: Layer -> IO RLayer +cnstrctRLayer lyr = do + nitms <- (mapM cnstrctRItem . view items) lyr + return (set gitems nitms emptyRLayer)+++{- -- | +mkRLayer :: Layer -> RLayer +mkRLayer lyr = let nitms = map mkRItem . view items $ lyr + in set gitems nitms emptyRLayer+ +-- | +mkRItem :: Item -> RItem +mkRItem (ItemStroke strk) = RItemStroke (mkStrokeBBox strk)+mkRItem (ItemImage img) = RItemImage (mkImageBBox img) Nothing +-} + +-- |+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 $ do + -- cairoDrawBkg dim bkg+ 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 +
+ src/Graphics/Hoodle/Render/Background.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- {-# LANGUAGE ExistentialQuantification, OverloadedStrings, +-- FlexibleInstances, FlexibleContexts, +-- TypeFamilies, CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.PDFBackground +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Background where++import Control.Monad.State hiding (mapM_)+import Data.ByteString hiding (putStrLn,filter)+import Data.Foldable (mapM_)+import Graphics.Rendering.Cairo+--+#ifdef POPPLER+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 Prelude hiding (mapM_)+ + +#ifdef POPPLER+popplerGetDocFromFile :: ByteString -> IO (Maybe Poppler.Document)+popplerGetDocFromFile fp = + Poppler.documentNewFromFile + (C.unpack ("file://localhost" `mappend` fp)) Nothing +#endif++#ifdef POPPLER +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)+ renderWith sfc $ do + setSourceRGBA 1 1 1 1+ rectangle 0 0 w h + fill+ PopplerPage.pageRender pg+ return (Just pg, Just sfc)+#endif++-- | draw ruling all +drawRuling :: Double -> Double -> ByteString -> Render () +drawRuling w h style = do+ let drawHorizRules = do + let (r,g,b,a) = predefined_RULING_COLOR + setSourceRGBA r g b a + setLineWidth predefined_RULING_THICKNESS+ let drawonerule y = do + moveTo 0 y + lineTo w y+ stroke + mapM_ drawonerule [ predefined_RULING_TOPMARGIN + , predefined_RULING_TOPMARGIN+predefined_RULING_SPACING+ .. + h-1 ]+ case style of + "plain" -> return () + "lined" -> do + drawHorizRules+ let (r2,g2,b2,a2) = predefined_RULING_MARGIN_COLOR+ setSourceRGBA r2 g2 b2 a2 + setLineWidth predefined_RULING_THICKNESS+ moveTo predefined_RULING_LEFTMARGIN 0 + lineTo predefined_RULING_LEFTMARGIN h+ stroke+ "ruled" -> drawHorizRules + "graph" -> do + let (r3,g3,b3,a3) = predefined_RULING_COLOR + setSourceRGBA r3 g3 b3 a3 + setLineWidth predefined_RULING_THICKNESS+ let drawonegraphvert x = do + moveTo x 0 + lineTo x h+ stroke + let drawonegraphhoriz y = do + moveTo 0 y+ lineTo w y+ stroke+ mapM_ drawonegraphvert [0,predefined_RULING_GRAPHSPACING..w-1] + mapM_ drawonegraphhoriz [0,predefined_RULING_GRAPHSPACING..h-1]+ _ -> return () ++++-- | draw ruling in bbox +drawRuling_InBBox :: BBox -> Double -> Double -> ByteString -> Render () +drawRuling_InBBox (BBox (x1,y1) (x2,y2)) w h style = do+ let drawonerule y = do + moveTo x1 y + lineTo x2 y+ stroke + let drawonegraphvert x = do + moveTo x y1 + lineTo x y2+ stroke + let drawonegraphhoriz y = do + moveTo x1 y+ lineTo x2 y+ stroke+ fullRuleYs = [ predefined_RULING_TOPMARGIN + , predefined_RULING_TOPMARGIN+predefined_RULING_SPACING+ .. + h-1 ]+ ruleYs = filter (\y-> (y <= y2) && (y >= y1)) fullRuleYs+ fullGraphXs = [0,predefined_RULING_GRAPHSPACING..w-1] + fullGraphYs = [0,predefined_RULING_GRAPHSPACING..h-1]+ graphXs = filter (\x->(x<=x2)&&(x>=x1)) fullGraphXs+ graphYs = filter (\y->(y<=y2)&&(y>=y1)) fullGraphYs + let drawHorizRules = do + let (r,g,b,a) = predefined_RULING_COLOR + setSourceRGBA r g b a + setLineWidth predefined_RULING_THICKNESS+ mapM_ drawonerule ruleYs+ case style of + "plain" -> return () + "lined" -> do + drawHorizRules+ let (r2,g2,b2,a2) = predefined_RULING_MARGIN_COLOR+ setSourceRGBA r2 g2 b2 a2 + setLineWidth predefined_RULING_THICKNESS+ moveTo predefined_RULING_LEFTMARGIN 0 + lineTo predefined_RULING_LEFTMARGIN h+ stroke+ "ruled" -> drawHorizRules + "graph" -> do + let (r3,g3,b3,a3) = predefined_RULING_COLOR + setSourceRGBA r3 g3 b3 a3 + setLineWidth predefined_RULING_THICKNESS+ mapM_ drawonegraphvert graphXs + mapM_ drawonegraphhoriz graphYs+ _ -> return () +++++-- instance RenderOptionable (BackgroundPDFDrawable,Dimension) where+ +
+ src/Graphics/Hoodle/Render/Generic.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Generic +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Generic where++import Control.Lens+import Data.Foldable+import Graphics.Rendering.Cairo+-- from hoodle-platform+import Data.Hoodle.BBox+import Data.Hoodle.Generic+import Data.Hoodle.Simple+-- from this package +import Graphics.Hoodle.Render+import Graphics.Hoodle.Render.Type +-- import Graphics.Hoodle.Render.Simple+-- import Graphics.Hoodle.Render.BBox+-- +import Prelude hiding (mapM_)++-- | +class Renderable a where + cairoRender :: a -> Render ()+ +-- | +instance Renderable (Background,Dimension) where+ cairoRender = renderBkg ++-- | +instance Renderable Stroke where + cairoRender = renderStrk ++-- | +instance Renderable StrokeBBox where+ cairoRender = renderStrk . strkbbx_strk+ +-- | +instance Renderable RLayer where+ cairoRender = renderRLayer_InBBox Nothing + +{- +-- | +instance Renderable RPage where+ cairoRender = renderRPage +-}++-- | +class RenderOptionable a where + type RenderOption a :: *+ cairoRenderOption :: RenderOption a -> a -> Render ()++-- | +instance RenderOptionable (Background,Dimension) where+ type RenderOption (Background,Dimension) = ()+ cairoRenderOption () = cairoRender ++-- | +instance RenderOptionable Stroke where+ type RenderOption Stroke = () + cairoRenderOption () = cairoRender+ +-- | +data StrokeBBoxOption = DrawFull | DrawBoxOnly ++-- | +instance RenderOptionable StrokeBBox where+ type RenderOption StrokeBBox = StrokeBBoxOption+ cairoRenderOption DrawFull = cairoRender + cairoRenderOption DrawBoxOnly = renderStrkBBx_BBoxOnly+ +-- | +instance RenderOptionable (RBackground,Dimension) where + type RenderOption (RBackground,Dimension) = RBkgOpt + -- cairoRenderOption :: RBkgOpt -> (RBackground,Dimension) -> Render ()+ cairoRenderOption RBkgDrawPDF = renderRBkg+ cairoRenderOption RBkgDrawWhite = renderRBkg_Dummy+ cairoRenderOption RBkgDrawBuffer = renderRBkg_Buf + cairoRenderOption (RBkgDrawPDFInBBox mbbox) = renderRBkg_InBBox mbbox ++-- | +instance RenderOptionable RLayer where+ type RenderOption RLayer = StrokeBBoxOption + cairoRenderOption DrawFull = cairoRender+ cairoRenderOption DrawBoxOnly = renderRLayer_BBoxOnly ++-- | +instance RenderOptionable (InBBox RLayer) where+ type RenderOption (InBBox RLayer) = InBBoxOption+ -- cairoRenderOption :: RLyrOpt -> RLayer -> Render () + cairoRenderOption (InBBoxOption mbbox) (InBBox lyr) = + renderRLayer_InBBoxBuf mbbox lyr+ +-- |+cairoOptionPage :: ( RenderOptionable (b,Dimension)+ , RenderOptionable a+ , Foldable s) => + (RenderOption (b,Dimension), RenderOption a) + -> GPage b s a + -> Render ()+cairoOptionPage (optb,opta) p = do + cairoRenderOption optb (view gbackground p, view gdimension p)+ mapM_ (cairoRenderOption opta) (view glayers p)+ +-- | +instance ( RenderOptionable (b,Dimension)+ , RenderOptionable a+ , Foldable s) =>+ RenderOptionable (GPage b s a) where+ type RenderOption (GPage b s a) = (RenderOption (b,Dimension), RenderOption a)+ cairoRenderOption = cairoOptionPage+ +{-+-- | +instance RenderOptionable (InBBox RLayer) where+ type RenderOption (InBBox RLayer) = InBBoxOption + cairoRenderOption (InBBoxOption mbbox) (InBBox layer) + = renderRLayer_InBBox mbbox layer +-}++-- | +instance RenderOptionable (InBBox RPage) where+ type RenderOption (InBBox RPage) = InBBoxOption + cairoRenderOption (InBBoxOption mbbox) (InBBox page) = do + cairoRenderOption (RBkgDrawPDFInBBox mbbox) (view gbackground page, view gdimension page) + mapM_ (renderRLayer_InBBox mbbox) . view glayers $ page ++++{-+instance Renderable (BackgroundPDFDrawable,Dimension) where+ cairoRender = cairoRenderBackgroundPDFDrawable+-}++{-+-- | +cairoLayer :: (Renderable a, Foldable s) => GLayer buf s a -> Render ()+cairoLayer = mapM_ cairoRender . gstrokes ++-- | +instance (Renderable a, Foldable s) => Renderable (GLayer s a) where+ cairoRender = cairoLayer ++-- | +cairoPage :: (Renderable (b,Dimension), Renderable a, Foldable s) => + GPage b s a -> Render ()+cairoPage p = do + cairoRender (gbackground p,gdimension p)+ mapM_ cairoRender (glayers p)++-- | +instance (Renderable (b,Dimension), Renderable a, Foldable s) + => Renderable (GPage b s a) where+ cairoRender = cairoPage +-}++++{-+-- | +cairoOptionLayer :: (RenderOptionable a, Foldable s) => + RenderOption a -> GLayer s a -> Render () +cairoOptionLayer opt = mapM_ (cairoRenderOption opt) . gstrokes ++-- | +instance (RenderOptionable a, Foldable s) => + RenderOptionable (GLayer s a) where+ type RenderOption (GLayer s a) = RenderOption a+ cairoRenderOption = cairoOptionLayer +-}+
+ src/Graphics/Hoodle/Render/Highlight.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Highlight+-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- collection of rendering routine that draws bounding box only+--+-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Highlight where++-- from others+import qualified Data.Map as M+import Graphics.Rendering.Cairo+-- from hoodle-platform +import Data.Hoodle.Simple+import Data.Hoodle.BBox+import Data.Hoodle.Predefined +-- from this package+import Graphics.Hoodle.Render.Primitive +import Graphics.Hoodle.Render.Type.Item +-- +import Prelude hiding (fst,snd,curry,uncurry,mapM_,concatMap)++-- | +renderStrkHltd :: StrokeBBox -> Render ()+renderStrkHltd sbbox = do + let s = strkbbx_strk 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 + case s of+ Stroke _ _ w d -> do + setLineWidth (w * 4.0) + setLineCap LineCapRound+ setLineJoin LineJoinRound+ drawStrokeCurve d+ stroke+ setSourceRGBA 1 1 1 1+ setLineWidth w+ drawStrokeCurve . stroke_data $ s + stroke+ VWStroke _ _ d -> do + setFillRule FillRuleWinding+ drawVWStrokeCurve $ map (\(x,y,z)->(x,y,4*z)) d+ fill + setSourceRGBA 1 1 1 1+ drawVWStrokeCurve d + fill+ +{- + Img _ _ _ -> cairoOneStrokeBBoxOnly sbbox + _ -> do + _ -> error "in cairoOneStrokeSelected"+-} +++-- | render items highlighted +renderRItemHltd :: RItem -> Render ()+renderRItemHltd (RItemStroke strk) = renderStrkHltd strk+renderRItemHltd (RItemImage img _) = do + setSourceRGBA 0 0 0 1+ setLineWidth 10 + let BBox (x1,y1) (x2,y2) = imgbbx_bbx img+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke++
+ src/Graphics/Hoodle/Render/Item.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TypeFamilies, TypeOperators, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Type.Item +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- Rendering RItem +-- +-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Item where++import qualified Data.ByteString.Char8 as C8+import Graphics.Rendering.Cairo+-- from hoodle-platform +import Data.Hoodle.BBox +import Data.Hoodle.Simple+-- from this package+import Graphics.Hoodle.Render.Type.Item ++-- | construct renderable item +cnstrctRItem :: Item -> IO RItem +cnstrctRItem (ItemStroke strk) = return (RItemStroke (mkStrokeBBox strk))+cnstrctRItem (ItemImage img) = do + let imgbbx = mkImageBBox img+ filesrc = C8.unpack (img_src img)+ sfc <- imageSurfaceCreateFromPNG filesrc+ -- rendering is not implemented yet+ return (RItemImage imgbbx (Just sfc))
+ src/Graphics/Hoodle/Render/Primitive.hs view
@@ -0,0 +1,60 @@++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Primitive+-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- draw utility +--+-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Primitive +( drawStrokeCurve +, drawVWStrokeCurve +) where ++import Control.Applicative+import Control.Monad +import Data.Strict.Tuple hiding (fst,snd)+import Graphics.Rendering.Cairo+-- from hoodle-platform+import Data.Hoodle.Predefined +-- +-- import Prelude hiding (foldM_)++------------------+-- draw utility -- +------------------++-- | +drawStrokeCurve :: [Pair Double Double] -> Render ()+drawStrokeCurve ((x0 :!: y0) : xs) = do + x0 `seq` y0 `seq` moveTo x0 y0+ mapM_ f xs + where f (x :!: y) = x `seq` y `seq` lineTo x y +drawStrokeCurve [] = return ()++-- | +drawVWStrokeCurve :: [(Double,Double,Double)] -> Render ()+drawVWStrokeCurve [] = return ()+drawVWStrokeCurve (_:[]) = return ()+drawVWStrokeCurve ((xo,yo,_zo) : xs) = do + moveTo xo yo+ let ((xlast,ylast,_zlast):rxs) = reverse xs + foldM_ forward (xo,yo) xs + foldM_ backward (xlast,ylast) rxs + where (dx,dy) = (,) <$> fst <*> snd $ predefinedPenShapeAspectXY+ dir (x,y) = x * dy - y * dx+ forward (x0,y0) (x,y,z) = do if (dir (x-x0,y-y0) > 0) + then lineTo (x+0.5*dx*z) (y+0.5*dy*z)+ else lineTo (x-0.5*dx*z) (y-0.5*dy*z) + return (x,y) + backward (x0,y0) (x,y,z) = do if (dir (x-x0,y-y0) < 0) + then lineTo (x-0.5*dx*z) (y-0.5*dy*z)+ else lineTo (x+0.5*dx*z) (y+0.5*dy*z)+ return (x,y)
+ src/Graphics/Hoodle/Render/Type.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TypeFamilies, TypeOperators, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Type +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- Renderable Hoodle Type +-- +-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Type +( module Graphics.Hoodle.Render.Type.Background+, module Graphics.Hoodle.Render.Type.Hoodle+, module Graphics.Hoodle.Render.Type.Item +, module Graphics.Hoodle.Render.Type.Select+) where++import Graphics.Hoodle.Render.Type.Background+import Graphics.Hoodle.Render.Type.Hoodle+import Graphics.Hoodle.Render.Type.Item+import Graphics.Hoodle.Render.Type.Select
+ src/Graphics/Hoodle/Render/Type/Background.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Type.Background +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Type.Background where++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 +-- from this package++-- +import Prelude hiding (mapM_)+++-- | +data Context = Context { ctxt_domain :: ByteString+ , ctxt_filename :: ByteString +#ifdef POPPLER+ , ctxt_doc :: Maybe Poppler.Document+#else+ , ctxt_doc :: Maybe ()+#endif + }++-- |++data RBackground = RBkgSmpl + { rbkg_color :: ByteString+ , rbkg_style :: ByteString+ , rbkg_cairosurface :: Maybe Surface }+ | RBkgPDF + { rbkg_domain :: Maybe ByteString+ , rbkg_filename :: Maybe ByteString+ , rbkg_pageno :: Int +#ifdef POPPLER+ , rbkg_popplerpage :: Maybe Poppler.Page +#else + , rbkg_popplerpage :: Maybe ()+#endif+ , rbkg_cairosurface :: Maybe Surface } ++data RBkgOpt = RBkgDrawPDF + | RBkgDrawWhite + | RBkgDrawBuffer+ | RBkgDrawPDFInBBox (Maybe BBox)++-- |+rbkg2Bkg :: RBackground -> Background +rbkg2Bkg (RBkgSmpl c s _) = Background "solid" c s +rbkg2Bkg (RBkgPDF d f n _ _ ) = BackgroundPdf "pdf" d f 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
+ src/Graphics/Hoodle/Render/Type/HitTest.hs view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Type.HitTest +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- Selection type+--+-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Type.HitTest where++import Data.Hoodle.BBox+-- +import Graphics.Hoodle.Render.Type.Item +--+import Prelude hiding (fst,snd)++-- |+data AlterList a b = Empty | a :- AlterList b a+ deriving (Show)++infixr 6 :-++-- | +newtype NotHitted a = NotHitted { unNotHitted :: [a] } + deriving (Show)++-- | +newtype Hitted a = Hitted { unHitted :: [a] } + deriving (Show)++-- | +type StrokeHitted = AlterList (NotHitted StrokeBBox) (Hitted StrokeBBox) ++-- | +type RItemHitted = AlterList (NotHitted RItem) (Hitted RItem) ++-- | +fmapAL :: (a -> c) -> (b -> d) -> AlterList a b -> AlterList c d+fmapAL _ _ Empty = Empty +fmapAL f g (x :- ys) = f x :- fmapAL g f ys ++-- | +getA :: AlterList a b -> [a] +getA Empty = [] +getA (x :- xs) = x : getB xs ++-- | +getB :: AlterList a b -> [b]+getB Empty = [] +getB (_x :- xs) = getA xs ++-- | +interleave :: (a->c) -> (b->c) -> AlterList a b -> [c]+interleave _fa _fb Empty = [] +interleave fa fb (x :- xs) = fa x : (interleave fb fa xs) ++----++-- | +type TAlterHitted a = AlterList [a] (Hitted a)++-- | +newtype TEitherAlterHitted a = + TEitherAlterHitted { + unTEitherAlterHitted :: Either [a] (TAlterHitted a)+ }+++-- |+takeHitted :: AlterList x (Hitted a) -> [a] +takeHitted = concatMap unHitted . getB ++-- |+isAnyHitted :: AlterList x (Hitted a) -> Bool +isAnyHitted = not . null . takeHitted
+ src/Graphics/Hoodle/Render/Type/Hoodle.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TypeFamilies, TypeOperators, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Type.Hoodle+-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- Renderable Hoodle Type +-- +-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Type.Hoodle where++import Control.Applicative+import Control.Lens +import Data.Foldable (toList)+import qualified Data.IntMap as IM+import Graphics.Rendering.Cairo +-- from hoodle-platform +import Data.Hoodle.BBox+import Data.Hoodle.Generic+import Data.Hoodle.Simple+import Data.Hoodle.Zipper+-- from this package+import Graphics.Hoodle.Render.Type.Background +import Graphics.Hoodle.Render.Type.Item++----------------------------+-- normal state rendering --+----------------------------++newtype LyBuf = LyBuf (Maybe Surface)++-- | normal rendering data structure for layer, R for rendering+-- buffer is Surface, container for item = list +-- and StrokeBBox as contained items+type RLayer = GLayer LyBuf [] RItem -- StrokeBBox ++-- | normal rendering data structure for page +-- background is RBackground and container for layer is IntMap +-- and layer is RLayer +type RPage = GPage RBackground ZipperSelect RLayer -- change from IntMap ++-- | normal rendering data struture for hoodle +-- container for page is IntMap +-- page is RPage+type RHoodle = GHoodle IM.IntMap RPage ++emptyRLayer :: RLayer +emptyRLayer = GLayer (LyBuf Nothing) []+++-------+-- get simple hoodle data structure +-------++-- | project to simple Layer out of RLayer +rLayer2Layer :: RLayer -> Layer+rLayer2Layer = Layer <$> fmap rItem2Item . view gitems ++ -- strkbbx_strk . view gstrokes++-- | project to simple Page out of RPage+rPage2Page :: RPage -> Page +rPage2Page = Page <$> view gdimension + <*> rbkg2Bkg . view gbackground + <*> fmap rLayer2Layer . toList . view glayers++-- | project to simple Hoodle out of RHoodle +rHoodle2Hoodle :: RHoodle -> Hoodle +rHoodle2Hoodle = Hoodle <$> view gtitle + <*> IM.elems . fmap rPage2Page . view gpages+++---------------------- +----- Rendering +----------------------++-- | +newtype InBBox a = InBBox a++-- | +data InBBoxOption = InBBoxOption (Maybe BBox) +
+ src/Graphics/Hoodle/Render/Type/Item.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TypeFamilies, TypeOperators, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Type.Item +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- Renderable Item Type +-- +-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Type.Item where++import Graphics.Rendering.Cairo+-- from hoodle-platform +import Data.Hoodle.BBox +import Data.Hoodle.Simple++data RItem = RItemStroke StrokeBBox + | RItemImage ImageBBox (Maybe Surface)++instance BBoxable RItem where+ getBBox (RItemStroke strk) = getBBox strk+ getBBox (RItemImage img _) = getBBox img ++-- | +isStrkInRItem :: RItem -> Bool +isStrkInRItem (RItemStroke _) = True+isStrkInRItem _ = False++-- |+isImgInRItem :: RItem -> Bool +isImgInRItem (RItemImage _ _) = True+isImgInRItem _ = False++-- | +findStrkInRItem :: RItem -> Maybe StrokeBBox +findStrkInRItem (RItemStroke strk) = Just strk+findStrkInRItem _ = Nothing ++-- | +findImgInRItem :: RItem -> Maybe ImageBBox+findImgInRItem (RItemImage img _ ) = Just img +findImgInRItem _ = Nothing ++++-- |+rItem2Item :: RItem -> Item +rItem2Item (RItemStroke strk) = (ItemStroke . strkbbx_strk) strk+rItem2Item (RItemImage img _) = (ItemImage . imgbbx_img) img++{-+-- | +rItemBBox :: RItem -> BBox +rItemBBox (RItemStroke strk) = strkbbx_bbx strk+rItemBBox (RItemImage img _) = imgbbx_bbx img++-}
+ src/Graphics/Hoodle/Render/Type/Select.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Type.Select +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++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 +import Data.Hoodle.Generic+import Data.Hoodle.Select+import Data.Hoodle.Zipper+-- import Data.Hoodle.Map+-- from this package+import Graphics.Hoodle.Render.Type.Background+import Graphics.Hoodle.Render.Type.HitTest+import Graphics.Hoodle.Render.Type.Hoodle +import Graphics.Hoodle.Render.Type.Item +++----------------------------+-- select state rendering --+----------------------------++type SLayerF a = GLayer (BufOf a) TEitherAlterHitted (ItmOf a) +++type family ItmOf a :: * + +type family BufOf a :: *+ +type instance BufOf (GLayer b s a) = b + +type instance ItmOf RLayer = RItem ++++data HLayersF s a = HLayersF+ { hlyrt_selectedLayer :: SLayerF a + , hlyrt_otherLayers :: s a+ }++type HLayers = HLayersF ZipperSelect RLayer+ +type HLayer = SLayerF RLayer + +selectedLayer :: Simple Lens HLayers HLayer +selectedLayer = lens hlyrt_selectedLayer (\f a -> f { hlyrt_selectedLayer=a }) ++otherLayers :: Simple Lens HLayers (ZipperSelect RLayer)+otherLayers = lens hlyrt_otherLayers (\f a -> f { hlyrt_otherLayers=a})++-- |+type HPage = + GPage RBackground (HLayersF ZipperSelect) RLayer++-- | +type HHoodle = + GSelect (IntMap RPage) (Maybe (Int, HPage))+++-- | +hLayer2RLayer :: HLayer -> RLayer +hLayer2RLayer l = + case unTEitherAlterHitted (view gitems l) of+ Left strs -> GLayer (view gbuffer l) strs + Right alist -> GLayer (view gbuffer l) . Prelude.concat + $ interleave id unHitted alist++-- | +hPage2RPage :: HPage -> RPage+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)+++-- | +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 + curr = current sz + currtemp = GLayer (view gbuffer curr) (TEitherAlterHitted . Left . view gitems $ curr)+ in GPage (view gdimension p) (view gbackground p) + (HLayersF currtemp normalizedothers)++++
+ src/Graphics/Hoodle/Render/Util.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Util +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- utility +--+-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Util where++import Graphics.Rendering.Cairo+-- +import Data.Hoodle.BBox++-- | +clipBBox :: Maybe BBox -> Render ()+clipBBox (Just (BBox (x1,y1) (x2,y2))) = do + resetClip + rectangle x1 y1 (x2-x1) (y2-y1)+ clip+clipBBox Nothing = resetClip ++-- | +clearBBox :: Maybe BBox -> Render () +clearBBox Nothing = return ()+clearBBox (Just (BBox (x1,y1) (x2,y2))) = do + save+ setSourceRGBA 0 0 0 0+ setOperator OperatorSource+ rectangle x1 y1 (x2-x1) (y2-y1) + fill+ restore
+ src/Graphics/Hoodle/Render/Util/HitTest.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Hoodle.Render.Util.HitTest +-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- Hit-testing routines+-- +-----------------------------------------------------------------------------++module Graphics.Hoodle.Render.Util.HitTest where+++import Control.Applicative+import Control.Monad.State+import Data.Strict.Tuple+-- from hoodle-platform+import Data.Hoodle.Simple +import Data.Hoodle.BBox +-- from this package+import Graphics.Hoodle.Render.Type.HitTest+import Graphics.Hoodle.Render.Type.Item ++--------------------------+-- hit test collections --+--------------------------++-- | hit test of whether a point in a bbox+-- previously, hitTestBBoxPoint +isPointInBBox :: BBox + -> (Double,Double) -- ^ point + -> Bool +isPointInBBox (BBox (ulx,uly) (lrx,lry)) (x,y) + = ulx <= x && x <= lrx && uly <= y && y <= lry ++-- | hit test of whether two lines intersect+do2LinesIntersect :: ((Double,Double),(Double,Double)) -- ^ line1+ -> ((Double,Double),(Double,Double)) -- ^ line2 + -> Bool +do2LinesIntersect ((x1,y1),(x2,y2)) ((x3,y3),(x4,y4)) = + (x2-xc)*(xc-x1)>=0 && (x3-xc)*(xc-x4) >=0 + where x21 = x2-x1 + x43 = x4-x3 + y21 = y2-y1 + y43 = y4-y3+ xc = (x21*x43*(y3-y1)+y21*x43*x1-y43*x21*x3)/(y21*x43-y43*x21)+ +-- | previously, hitTestLineStroke+doesLineHitStrk :: ((Double,Double),(Double,Double)) -> Stroke -> Bool+doesLineHitStrk line1 str@(Stroke _t _c _w _d) = + test (stroke_data str) + where test [] = False+ test ((_:!:_):[]) = False+ test ((x0:!:y0):(x:!:y):rest) + = do2LinesIntersect line1 ((x0,y0),(x,y))+ || test ((x:!:y) : rest)+doesLineHitStrk line1 (VWStroke _t _c d) = test d + where test [] = False+ test ((_,_,_):[]) = False+ test ((x0,y0,_):(x,y,z):rest) + = do2LinesIntersect line1 ((x0,y0),(x,y))+ || test ((x,y,z) : rest)++-- | Do two bounding boxes intersect with each other?+-- previously, hitTestBBoxBBox+do2BBoxIntersect :: BBox -> BBox -> Bool +do2BBoxIntersect b1@(BBox (ulx1,uly1) (lrx1,lry1)) b2@(BBox (ulx2,uly2) (lrx2,lry2))+ = isPointInBBox b2 (ulx1,uly1)+ || isPointInBBox b2 (lrx1,lry1)+ || isPointInBBox b2 (lrx1,uly1)+ || isPointInBBox b2 (ulx1,lry1)+ || isPointInBBox b1 (lrx2,lry2)+ || isPointInBBox b1 (ulx2,uly2)++-- | is the second bbox inside the first bbox?+-- previously, hitTestInsideBBox+isBBox2InBBox1 :: BBox -- ^ 1st bbox+ -> BBox -- ^ 2nd bbox + -> Bool +isBBox2InBBox1 b1 (BBox (ulx2,uly2) (lrx2,lry2)) + = isPointInBBox b1 (ulx2,uly2) && isPointInBBox b1 (lrx2,lry2)++--------------------------------------------------------+-- item filtering functions that results in AlterList -- +--------------------------------------------------------++-- | +hltFilteredBy_StateT :: (a -> Bool) -- ^ hit test condition+ -> [a] -- ^ strokes to test + -> State Bool (AlterList (NotHitted a) (Hitted a))+hltFilteredBy_StateT test itms = do + let (nhit,rest) = break test itms+ (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 :- hltFilteredBy test rest')+++-- | highlight strokes filtered by a condition. +-- previously mkHitTestAL+hltFilteredBy :: (a -> Bool) -- ^ hit test condition+ -> [a] -- ^ strokes to test + -> AlterList (NotHitted a) (Hitted a)+hltFilteredBy test is = evalState (hltFilteredBy_StateT test is) False++++-- | +hltHittedByBBox :: (BBoxable a) => + BBox -- ^ test bounding box+ -> [a] -- ^ items to test+ -> AlterList (NotHitted a) (Hitted a)+hltHittedByBBox b = hltFilteredBy (do2BBoxIntersect b . getBBox) ++-- | +hltEmbeddedByBBox :: (BBoxable 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) => + ((Double,Double),(Double,Double)) -- ^ line + -> [a] -- ^ items to test+ -> AlterList (NotHitted a) (Hitted a)+hltHittedByLineRough (p1,p2) = hltFilteredBy boxhittest + where boxhittest s = isPointInBBox (getBBox s) p1+ || isPointInBBox (getBBox s) p2+++-- |+hltItmsHittedByLine_StateT :: ((Double,Double),(Double,Double))+ -> [RItem]+ -> State Bool RItemHitted+ -- (AlterList (NotHitted RItem) (Hitted RItem))+hltItmsHittedByLine_StateT line = hltFilteredBy_StateT test + where test (RItemStroke strk) = (doesLineHitStrk line . strkbbx_strk) strk+ test _ = False + +++-- |+hltItmsHittedByLineFrmSelected_StateT :: + ((Double,Double),(Double,Double))+ -> RItemHitted -- AlterList (NotHitted RItem) (Hitted RItem)+ -> State Bool (AlterList (NotHitted RItem) RItemHitted)+hltItmsHittedByLineFrmSelected_StateT _ Empty + = error "something is wrong, invariant broken"+hltItmsHittedByLineFrmSelected_StateT _ (n:-Empty) = return (n:-Empty)+hltItmsHittedByLineFrmSelected_StateT line (n:-h:-rest) = do + h' <- hltItmsHittedByLine_StateT line (unHitted h)+ (n:-) . (h':-) <$> hltItmsHittedByLineFrmSelected_StateT line rest++++---------------------------------------------+-- 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) => + AlterList (NotHitted a) (Hitted a) -> State (Maybe BBox) [a]+elimHitted Empty = error "something wrong in elimHitted"+elimHitted (n:-Empty) = return (unNotHitted n)+elimHitted (n:-h:-rest) = do + bbox <- get+ let bbox2 = getTotalBBox (unHitted h) + put (merge bbox bbox2) + return . (unNotHitted n ++) =<< elimHitted rest+++-- | +merge :: Maybe BBox -> Maybe BBox -> Maybe BBox +merge Nothing Nothing = Nothing+merge Nothing (Just b) = Just b+merge (Just b) Nothing = Just b +merge (Just (BBox (x1,y1) (x2,y2))) (Just (BBox (x3,y3) (x4,y4))) + = Just (BBox (min x1 x3, min y1 y3) (max x2 x4,max y2 y4)) + +-- | +getTotalBBox :: (BBoxable a) => [a] -> Maybe BBox +getTotalBBox = foldl f Nothing + where f acc = merge acc . Just . getBBox+