diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2016, Michael Smith +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. + +* Neither the name of liquidhaskell-cabal nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/demo/Demo.hs b/demo/Demo.hs new file mode 100644 --- /dev/null +++ b/demo/Demo.hs @@ -0,0 +1,30 @@ +import Diagrams.Prelude as D +import Diagrams.Backend.Cairo +import Diagrams.Backend.WX + +import Graphics.UI.WX as W hiding (circle, (#)) +import qualified Graphics.UI.WX.Types as W + +main :: IO () +main = W.start $ do + f <- W.frame [W.text := "diagrams-wx demo"] + p <- panel f [on paint := paintDiagram] + + W.set f [ fullRepaintOnResize := False + , layout := minsize (sz 300 300) $ fill $ widget p + ] + +paintDiagram :: DC a -> Rect -> IO () +paintDiagram dc rect = drawDiagram dc sampleDiagram pt rs W.white [] + where + pt = W.Point (rectLeft rect) (rectTop rect) + rs = dims2D (fromIntegral $ rectWidth rect) (fromIntegral $ rectHeight rect) + +sampleDiagram :: QDiagram Cairo V2 Double Any +sampleDiagram = mconcat + [ circle 0.1 # fc D.green + , triangle 1 # scale 0.4 # fc D.yellow + , square 1 # fc D.blue + , circle 1 # fc D.red + ] + diff --git a/diagrams-wx.cabal b/diagrams-wx.cabal new file mode 100644 --- /dev/null +++ b/diagrams-wx.cabal @@ -0,0 +1,45 @@ +name: diagrams-wx +version: 0.1.0.0 +synopsis: Backend for rendering diagrams in wxWidgets +description: An optional add-on to the diagrams-cairo package which + allows rendering diagrams in wxWidgets (using wxHaskell). +homepage: https://github.com/spinda/diagrams-wx#readme +bug-reports: https://github.com/spinda/diagrams-wx/issues +license: BSD3 +license-file: LICENSE +author: Michael Smith +maintainer: Michael Smith +copyright: 2016 Michael Smith +category: Graphics +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Diagrams.Backend.WX + build-depends: base >= 4.4 && < 5 + , cairo >= 0.12.4 && < 0.14 + , diagrams-cairo >= 1.3 && < 1.4 + , diagrams-lib >= 1.3 && < 1.4 + , wx >= 0.92 && < 0.93 + , wxcore >= 0.92 && < 0.93 + default-language: Haskell2010 + c-sources: lib/util.c + +executable diagrams-wx-demo + hs-source-dirs: demo + main-is: Demo.hs + build-depends: base + , diagrams-wx + , cairo >= 0.12.4 && < 0.14 + , diagrams-cairo >= 1.3 && < 1.4 + , diagrams-lib >= 1.3 && < 1.4 + , wx >= 0.92 && < 0.93 + , wxcore >= 0.92 && < 0.93 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/spinda/diagrams-wx + diff --git a/lib/util.c b/lib/util.c new file mode 100644 --- /dev/null +++ b/lib/util.c @@ -0,0 +1,23 @@ +#include +#include + +void copyCairoToWxWidgets ( float r, float g, float b + , ptrdiff_t size, unsigned char * cairo + , unsigned char * wx + ) { + + unsigned char * cairoEnd = cairo + size; + + while (cairo < cairoEnd) { + float a1 = (float) cairo[3] / 255; + float a2 = 1 - a1; + + wx[0] = (unsigned char) ((float) cairo[2] * a1 + r * a2); + wx[1] = (unsigned char) ((float) cairo[1] * a1 + g * a2); + wx[2] = (unsigned char) ((float) cairo[0] * a1 + b * a2); + + cairo += 4; + wx += 3; + } +} + diff --git a/src/Diagrams/Backend/WX.hs b/src/Diagrams/Backend/WX.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/WX.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | An optional add-on to the +-- +-- package which allows rendering diagrams in wxWidgets (using +-- ). +-- +-- wxHaskell doesn't support transparency when drawing 'Image's, so each +-- of these functions takes a 'W.Color' to use as the background color +-- when rendering the 'QDiagram'. +module Diagrams.Backend.WX ( + -- * Drawing to DC + drawDiagram + -- * Drawing to uImages + , withDiagramImage + , renderDiagramToNewImage + , renderDiagramToImage + , ImageSizeException(..) + ) where + +import Control.Exception +import Control.Monad + +import Data.Bifunctor +import Data.Typeable + +import Diagrams.Prelude +import Diagrams.Backend.Cairo +import Diagrams.Backend.Cairo.Internal + +import Graphics.Rendering.Cairo + +import Graphics.UI.WX as W hiding (bracket, when) +import Graphics.UI.WX.Draw + +import Graphics.UI.WXCore.Image +import Graphics.UI.WXCore.WxcClassesAL +import Graphics.UI.WXCore.WxcClassTypes + +import Foreign +import Foreign.C.Types + +-------------------------------------------------------------------------------- +-- Drawing to DC --------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | Simple interface for drawing a diagram to a 'DC', like 'drawImage'. +-- +-- Note that this creates, renders to, draws, and then deletes a +-- new 'Image' instance every invocation. Particularly performance-sensitive +-- users may want to look at using 'renderDiagramToImage' with the same 'Image' +-- instance every repaint. +drawDiagram :: (Monoid b, Semigroup b) + => DC a + -> QDiagram Cairo V2 Double b -> W.Point -> SizeSpec V2 Double + -> W.Color -> [Prop (DC a)] -> IO () +drawDiagram dc diagram point size bgColor props = + withDiagramImage diagram size bgColor $ \image -> + drawImage dc image point props + +-------------------------------------------------------------------------------- +-- Drawing to Images ----------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | Safe wrapper around 'renderDiagramToNewImage' that ensures the 'Image' +-- instance is properly deleted when you're done using it. +-- +-- > withDiagramImage diagram size = +-- > bracket (renderDiagramToNewImage diagram size) imageDelete +withDiagramImage :: (Monoid b, Semigroup b) + => QDiagram Cairo V2 Double b -> SizeSpec V2 Double + -> W.Color -> (Image () -> IO c) -> IO c +withDiagramImage diagram size bgColor = + bracket (renderDiagramToNewImage diagram size bgColor) imageDelete + +-- | Create a new 'Image' of the appropriate size and render the given +-- 'QDiagram' to it with Cairo. +-- +-- Make sure 'imageDelete' is called to free the 'Image' instance! Using +-- 'bracket' is recommended to ensure that the 'Image' is still freed in the +-- case of an exception: +-- +-- > bracket (renderDiagramToNewImage diagram size) imageDelete doStuffWithImage +-- +-- 'withDiagramImage' provides a convenient wrapper for this. +renderDiagramToNewImage :: (Monoid b, Semigroup b) + => QDiagram Cairo V2 Double b -> SizeSpec V2 Double + -> W.Color -> IO (Image ()) +renderDiagramToNewImage diagram size bgColor = do + let (w, h) = finalSize size diagram + image <- imageCreateSized $ sz w h + renderDiagramToImage' w h diagram bgColor image + return image + +-- | Render a 'QDiagram' to an existing 'Image'. Throws an 'ImageSizeException' +-- if the target 'Image' is too small for the resulting rendered diagram size. +renderDiagramToImage :: (Monoid b, Semigroup b) + => QDiagram Cairo V2 Double b -> SizeSpec V2 Double + -> W.Color -> Image i -> IO () +renderDiagramToImage diagram size bgColor image = do + let (w, h) = finalSize size diagram + w' <- imageGetWidth image + h' <- imageGetHeight image + when (w' < w || w' < h) $ throw $ ImageSizeException (w, h) (w', h') + renderDiagramToImage' w h diagram bgColor image + +renderDiagramToImage' :: (Monoid b, Semigroup b) + => Int -> Int -> QDiagram Cairo V2 Double b + -> W.Color -> Image i -> IO () +renderDiagramToImage' w h diagram bgColor image = do + let fmt = FormatARGB32 + let stride = formatStrideForWidth fmt w + let size = stride * h + let opt = CairoOptions + { _cairoSizeSpec = fromIntegral <$> dims2D w h + , _cairoOutputType = RenderOnly + , _cairoBypassAdjust = False + , _cairoFileName = "" + } + (_, r) = renderDia Cairo opt diagram + + bracket (callocArray size) free $ \cairoPtr -> do + withImageSurfaceForData cairoPtr fmt w h stride (`renderWith` r) + withImageData image $ \wxPtr -> copyCairoToWxWidgets + (colorRed bgColor) (colorGreen bgColor) (colorBlue bgColor) + (fromIntegral size) cairoPtr (castPtr wxPtr) + +finalSize :: (Monoid b, Semigroup b) + => SizeSpec V2 Double -> QDiagram Cairo V2 Double b -> (Int, Int) +finalSize size = unr2 . fmap ceiling . fst . sizeAdjustment size . boundingBox + +-- | Exception indicating that the target image was the wrong size (too small) +-- for the rendered diagram size. +data ImageSizeException + -- | @ImageSizeException renderedDiagramSize targetImageSize@ + = ImageSizeException !(Int, Int) !(Int, Int) + deriving (Show, Typeable) + +instance Exception ImageSizeException where + displayException (ImageSizeException needed avail) = + "Can't render diagram with output size " + ++ show needed + ++ " to image of size " + ++ show avail + +foreign import ccall "util.c copyCairoToWxWidgets" + copyCairoToWxWidgets :: CFloat -> CFloat -> CFloat + -> CPtrdiff -> Ptr CUChar -> Ptr CUChar + -> IO () +