diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,18 @@ +0.1: 17 May 2011 + * initial preview release + +0.1.1: 18 May 2011 + * fix tic-tac-toe example + +0.1.2: 18 May 2011 + * link to new website + +0.2: 3 June 2011 + + * add Typeable and other instances for Cairo type + + * generalize Result type to (IO (), Render ()), so programs that + don't want to generate a file but just want a Render operation + (e.g. to use to paint a gtk window) can use the second component. + + * add support for opacity attribute and path clipping diff --git a/diagrams-cairo.cabal b/diagrams-cairo.cabal --- a/diagrams-cairo.cabal +++ b/diagrams-cairo.cabal @@ -1,5 +1,5 @@ Name: diagrams-cairo -Version: 0.1.2 +Version: 0.2 Synopsis: Cairo backend for diagrams drawing EDSL Description: This package provides a modular backend for rendering diagrams created with the diagrams EDSL using the @@ -13,6 +13,7 @@ Category: Graphics Build-type: Simple Cabal-version: >=1.6 +Extra-source-files: CHANGES Tested-with: GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3 Extra-source-files: example/*.hs, example/tic-tac-toe/*.hs Source-repository head @@ -27,10 +28,10 @@ process >= 1.0 && < 1.1, directory >= 1.0 && < 1.2, old-time >= 1.0 && < 1.1, - diagrams-core >= 0.1 && < 0.2, - diagrams-lib >= 0.1 && < 0.2, + diagrams-core >= 0.2 && < 0.3, + diagrams-lib >= 0.2 && < 0.3, cairo >= 0.10.1 && < 0.13, - cmdargs >= 0.6 && < 0.7, + cmdargs >= 0.6 && < 0.8, split >= 0.1.2 && < 0.2 if !os(windows) cpp-options: -DCMDLINELOOP diff --git a/example/Hasse.hs b/example/Hasse.hs new file mode 100644 --- /dev/null +++ b/example/Hasse.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +import Diagrams.Prelude +import Diagrams.Backend.Cairo.CmdLine + +import Data.List +import Data.Ord (comparing) +import Data.Function (on) + +type D = Diagram Cairo R2 + +colors = [black, blue, red, yellow, green, orange, purple, brown] + +data Subset = Subset Int [Int] + +(Subset _ elts1) `isSubset` (Subset _ elts2) = all (`elem` elts2) elts1 + +subsetsBySize :: Int -> [[Subset]] +subsetsBySize n = map (map (Subset n)) + . groupBy ((==) `on` length) + . sortBy (comparing length) + . subsequences + $ [1..n] + +drawSet :: Subset -> D +drawSet (Subset n elts) = ( drawElts n elts # centerXY + <> square # scaleX (fromIntegral n + 0.5) # scaleY 1.5 + # dashing [0.2,0.2] 0 + # lw 0.03 + # namePoint (boundary (negateV unitY)) "B" + # namePoint (boundary unitY) "T" + # (show elts |>) + ) + # freeze + +drawElts n elts = hcat . map (\i -> if i `elem` elts then drawElt i else strutX 1) $ [1..n] +drawElt e = square # fc (colors !! e) # lw 0.05 # freeze + + +hasseDiagram n = setsD # drawConnections + where setsD = vcat' with {sep = fromIntegral n} . map hasseRow . reverse $ subsets + drawConnections = applyAll connections + connections = concat $ zipWith connectSome subsets (tail subsets) + connectSome subs1 subs2 = [ connect s1 s2 | s1 <- subs1 + , s2 <- subs2 + , s1 `isSubset` s2 ] + connect (Subset _ elts1) (Subset _ elts2) = + withName (show elts1 ||> "T") $ \p1 -> + withName (show elts2 ||> "B") $ \p2 -> + (<> stroke (fromVertices [p1,p2]) # lw 0.03) + subsets = subsetsBySize n + +hasseRow = centerX . hcat' with {sep = 2} . map drawSet + +main = defaultMain (pad 1.1 $ hasseDiagram 4) diff --git a/example/Hilbert.hs b/example/Hilbert.hs new file mode 100644 --- /dev/null +++ b/example/Hilbert.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +import Diagrams.Prelude +import Diagrams.Backend.Cairo.CmdLine + +hilbert :: [Trail R2] +hilbert = iterate genHilbert mempty + where genHilbert t = let t' = reverseTrail t + in mconcat [ rotateBy (-1/4) t' + , fromOffsets [unitY] + , t + , fromOffsets [unitX] + , t + , fromOffsets [negateV unitY] + , rotateBy (1/4) t' + ] + +d = (hilbert !! 6) + # strokeT + # lw 0.2 + # fc red + # centerXY + # pad 1.1 + +main = defaultMain d diff --git a/example/golden.hs b/example/golden.hs --- a/example/golden.hs +++ b/example/golden.hs @@ -7,14 +7,15 @@ type D = Diagram Cairo R2 sq :: D -sq = (lw 1 . stroke $ arc (pi / 2) pi) `atop` (translate (-0.5, 0.5) . lw 0.5 $ square) +sq = (lw 1 . stroke $ arc (pi / 2 :: Rad) (pi :: Rad)) + `atop` (translate (-0.5, 0.5) . lw 0.5 $ square) phi :: Double phi = (1 + sqrt 5) / 2 step :: D -> D -> D step a b = besideAlign (-1,0) (0,1) a b' - where b' = rotate (-pi/2) . scale (1/phi) $ b + where b' = rotate (-pi/2 :: Rad) . scale (1/phi) $ b besideAlign :: R2 -> R2 -> D -> D -> D besideAlign u v a b = beside u b' a diff --git a/example/gray.hs b/example/gray.hs --- a/example/gray.hs +++ b/example/gray.hs @@ -16,17 +16,17 @@ where g = gray (n-1) rings n = mkRingsDia . map ringOffsets . transpose . gray $ n - where ringOffsets :: [Bool] -> [(Angle, Angle)] - ringOffsets = map l2t . chunk 2 . findEdges . zip [0,2*pi/(2^n)..2*pi] + where ringOffsets :: [Bool] -> [(CircleFrac, CircleFrac)] + ringOffsets = map l2t . chunk 2 . findEdges . zip [0,1/(2^n)..1] l2t [x,y] = (x,y) l2t [x] = (x,2*pi) -findEdges :: Eq a => [(Angle, a)] -> [Angle] +findEdges :: Eq a => [(CircleFrac, a)] -> [CircleFrac] findEdges = catMaybes . (zipWith edge <*> tail) where edge (_,c1) (a,c2) | c1 /= c2 = Just a | otherwise = Nothing -mkRingsDia :: [[(Angle, Angle)]] -> D +mkRingsDia :: [[(CircleFrac, CircleFrac)]] -> D mkRingsDia = freeze . mconcat . zipWith mkRingDia [2,3..] where mkRingDia r = lw 1.05 . mconcat . map (stroke . scale r . uncurry arc) diff --git a/example/hslogo.hs b/example/hslogo.hs --- a/example/hslogo.hs +++ b/example/hslogo.hs @@ -33,7 +33,7 @@ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -import Diagrams.Prelude +import Diagrams.Prelude hiding (intersection) import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo.CmdLine diff --git a/example/paradox.hs b/example/paradox.hs --- a/example/paradox.hs +++ b/example/paradox.hs @@ -2,8 +2,6 @@ import Diagrams.Prelude import Diagrams.Backend.Cairo.CmdLine -import Diagrams.TwoD.Align -- for abbreviations - fibs = 0 : 1 : zipWith (+) fibs (tail fibs) thick = 0.15 diff --git a/src/Diagrams/Backend/Cairo.hs b/src/Diagrams/Backend/Cairo.hs --- a/src/Diagrams/Backend/Cairo.hs +++ b/src/Diagrams/Backend/Cairo.hs @@ -3,6 +3,8 @@ , FlexibleInstances , FlexibleContexts , TypeSynonymInstances + , DeriveDataTypeable + , ViewPatterns #-} ----------------------------------------------------------------------------- @@ -31,15 +33,19 @@ import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo.Matrix as CM +import Control.Applicative ((<$>)) import Control.Monad (when) import Data.Maybe (catMaybes) import Data.Monoid import qualified Data.Foldable as F +import Data.Typeable + -- | This data declaration is simply used as a token to distinguish -- this rendering engine. data Cairo = Cairo + deriving (Eq,Ord,Read,Show,Typeable) -- | Cairo is able to output to several file formats, which each have -- their own associated properties that affect the output. @@ -60,7 +66,7 @@ instance Backend Cairo R2 where data Render Cairo R2 = C (C.Render ()) - type Result Cairo R2 = IO () + type Result Cairo R2 = (IO (), C.Render ()) data Options Cairo R2 = CairoOptions { fileName :: String -- ^ the name of the file you want generated , outputFormat :: OutputFormat -- ^ the output format and associated options @@ -68,23 +74,25 @@ withStyle _ s t (C r) = C $ do C.save + doClip s r cairoTransf t cairoStyle s C.stroke C.restore - doRender _ options (C r) = do - let surfaceF surface = C.renderWith surface r - file = fileName options - case outputFormat options of - PNG (w,h) -> do - C.withImageSurface C.FormatARGB32 w h $ \surface -> do - surfaceF surface - C.surfaceWriteToPNG surface file - PS (w,h) -> C.withPSSurface file w h surfaceF - PDF (w,h) -> C.withPDFSurface file w h surfaceF - SVG (w,h) -> C.withSVGSurface file w h surfaceF + doRender _ options (C r) = (renderIO, r) + where renderIO = do + let surfaceF s = C.renderWith s r + file = fileName options + case outputFormat options of + PNG (w,h) -> + C.withImageSurface C.FormatARGB32 w h $ \surface -> do + surfaceF surface + C.surfaceWriteToPNG surface file + PS (w,h) -> C.withPSSurface file w h surfaceF + PDF (w,h) -> C.withPDFSurface file w h surfaceF + SVG (w,h) -> C.withSVGSurface file w h surfaceF -- Set the line width to 0.01 and line color to black (in case they -- were not set), freeze the diagram in its final form, and then do @@ -109,8 +117,13 @@ renderC :: (Renderable a Cairo, V a ~ R2) => a -> C.Render () renderC a = case (render Cairo a) of C r -> r -cairoStyle :: Style -> C.Render () -cairoStyle s = foldr (>>) (return ()) +doClip :: Style v -> C.Render () +doClip s = case getAttr s of + Just (Clip ps) -> mapM_ (\p -> renderC p >> C.clip) ps + Nothing -> return () + +cairoStyle :: Style v -> C.Render () +cairoStyle s = sequence_ . catMaybes $ [ handle fColor , handle lColor -- see Note [color order] , handle lWidth @@ -120,20 +133,23 @@ ] where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ()) handle f = f `fmap` getAttr s - fColor (FillColor (SomeColor c)) = do - let (r,g,b,a) = colorToRGBA c - C.setSourceRGBA r g b a + fColor c = do + let (r,g,b,a) = colorToRGBA . getFillColor $ c + let a' = case getOpacity <$> getAttr s of + Nothing -> a + Just d -> a * d + C.setSourceRGBA r g b a' C.fillPreserve - lColor (LineColor (SomeColor c)) = do - let (r,g,b,a) = colorToRGBA c - C.setSourceRGBA r g b a - lWidth (LineWidth w) = do - C.setLineWidth w - lCap lcap = do - C.setLineCap (fromLineCap lcap) - lJoin lj = do - C.setLineJoin (fromLineJoin lj) - lDashing (Dashing ds offs) = do + lColor c = do + let (r,g,b,a) = colorToRGBA . getLineColor $ c + let a' = case getOpacity <$> getAttr s of + Nothing -> a + Just d -> a * d + C.setSourceRGBA r g b a' + lWidth = C.setLineWidth . getLineWidth + lCap = C.setLineCap . fromLineCap . getLineCap + lJoin = C.setLineJoin . fromLineJoin . getLineJoin + lDashing (getDashing -> Dashing ds offs) = C.setDash ds offs cairoTransf :: Transformation R2 -> C.Render () @@ -164,7 +180,7 @@ render _ ell = C $ do let P (xc,yc) = ellipseCenter ell (xs,ys) = ellipseScale ell - th = ellipseAngle ell + Rad th = ellipseAngle ell C.newPath C.save C.translate xc yc @@ -181,10 +197,10 @@ instance Renderable (Trail R2) Cairo where render _ (Trail segs c) = C $ do mapM_ renderC segs - when c $ C.closePath + when c C.closePath instance Renderable (Path R2) Cairo where render _ (Path trs) = C $ C.newPath >> F.mapM_ renderTrail trs - where renderTrail (tr, P p) = do + where renderTrail (P p, tr) = do uncurry C.moveTo p renderC tr diff --git a/src/Diagrams/Backend/Cairo/CmdLine.hs b/src/Diagrams/Backend/Cairo/CmdLine.hs --- a/src/Diagrams/Backend/Cairo/CmdLine.hs +++ b/src/Diagrams/Backend/Cairo/CmdLine.hs @@ -98,7 +98,7 @@ #endif chooseRender :: DiagramOpts -> Diagram Cairo R2 -> IO () -chooseRender opts d = do +chooseRender opts d = case splitOn "." (output opts) of [""] -> putStrLn "No output file given." ps | last ps `elem` ["png", "ps", "pdf", "svg"] -> do @@ -108,7 +108,7 @@ "pdf" -> PDF (fromIntegral $ width opts, fromIntegral $ height opts) "svg" -> SVG (fromIntegral $ width opts, fromIntegral $ height opts) _ -> PDF (fromIntegral $ width opts, fromIntegral $ height opts) - renderDia Cairo (CairoOptions (output opts) outfmt) d + fst $ renderDia Cairo (CairoOptions (output opts) outfmt) d | otherwise -> putStrLn $ "Unknown file type: " ++ last ps multiMain :: [(String, Diagram Cairo R2)] -> IO ()