diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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 +> -- } diff --git a/hoodle-render.cabal b/hoodle-render.cabal new file mode 100644 --- /dev/null +++ b/hoodle-render.cabal @@ -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 +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 diff --git a/src/Graphics/Hoodle/Render.hs b/src/Graphics/Hoodle/Render.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render.hs @@ -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 +-- 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 + diff --git a/src/Graphics/Hoodle/Render/Background.hs b/src/Graphics/Hoodle/Render/Background.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Background.hs @@ -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 +-- 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 + + diff --git a/src/Graphics/Hoodle/Render/Generic.hs b/src/Graphics/Hoodle/Render/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Generic.hs @@ -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 +-- 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 +-} + diff --git a/src/Graphics/Hoodle/Render/Highlight.hs b/src/Graphics/Hoodle/Render/Highlight.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Highlight.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Hoodle.Render.Highlight +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + + diff --git a/src/Graphics/Hoodle/Render/Item.hs b/src/Graphics/Hoodle/Render/Item.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Item.hs @@ -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 +-- 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)) diff --git a/src/Graphics/Hoodle/Render/Primitive.hs b/src/Graphics/Hoodle/Render/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Primitive.hs @@ -0,0 +1,60 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Hoodle.Render.Primitive +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) diff --git a/src/Graphics/Hoodle/Render/Type.hs b/src/Graphics/Hoodle/Render/Type.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Type.hs @@ -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 +-- 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 diff --git a/src/Graphics/Hoodle/Render/Type/Background.hs b/src/Graphics/Hoodle/Render/Type/Background.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Type/Background.hs @@ -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 +-- 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 diff --git a/src/Graphics/Hoodle/Render/Type/HitTest.hs b/src/Graphics/Hoodle/Render/Type/HitTest.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Type/HitTest.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Hoodle.Render.Type.HitTest +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 diff --git a/src/Graphics/Hoodle/Render/Type/Hoodle.hs b/src/Graphics/Hoodle/Render/Type/Hoodle.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Type/Hoodle.hs @@ -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 +-- 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) + diff --git a/src/Graphics/Hoodle/Render/Type/Item.hs b/src/Graphics/Hoodle/Render/Type/Item.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Type/Item.hs @@ -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 +-- 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 + +-} diff --git a/src/Graphics/Hoodle/Render/Type/Select.hs b/src/Graphics/Hoodle/Render/Type/Select.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Type/Select.hs @@ -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 +-- 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) + + + + diff --git a/src/Graphics/Hoodle/Render/Util.hs b/src/Graphics/Hoodle/Render/Util.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Util.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Hoodle.Render.Util +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 diff --git a/src/Graphics/Hoodle/Render/Util/HitTest.hs b/src/Graphics/Hoodle/Render/Util/HitTest.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hoodle/Render/Util/HitTest.hs @@ -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 +-- 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 +