diff --git a/IHaskell/Display/Diagrams.hs b/IHaskell/Display/Diagrams.hs --- a/IHaskell/Display/Diagrams.hs +++ b/IHaskell/Display/Diagrams.hs @@ -1,35 +1,33 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} -module IHaskell.Display.Diagrams (diagram, animation) where +module IHaskell.Display.Diagrams + ( diagram, animation + , ManuallySized, withSizeSpec, withImgWidth, withImgHeight + ) where import qualified Data.ByteString.Char8 as Char import System.Directory -import System.IO.Unsafe import Diagrams.Backend.Cairo import Diagrams.Prelude import IHaskell.Display import IHaskell.Display.Diagrams.Animation +import IHaskell.Display.Diagrams.ImgSize -instance IHaskellDisplay (QDiagram Cairo V2 Double Any) where +instance IHaskellDisplay (ManuallySized (QDiagram Cairo V2 Double Any)) where display renderable = do png <- diagramData renderable PNG svg <- diagramData renderable SVG return $ Display [png, svg] -diagramData :: Diagram Cairo -> OutputType -> IO DisplayData -diagramData renderable format = do +diagramData :: ManuallySized (Diagram Cairo) -> OutputType -> IO DisplayData +diagramData (ManuallySized renderable imgWidth imgHeight) format = do switchToTmpDir - -- Compute width and height. - let w = width renderable - h = height renderable - aspect = w / h - imgHeight = 300 - imgWidth = aspect * imgHeight - -- Write the image. let filename = ".ihaskell-diagram." ++ extension format - renderCairo filename (mkSizeSpec2D (Just imgWidth) (Just imgHeight)) renderable + renderCairo filename (mkSizeSpec2D (Just imgWidth) + (Just imgHeight)) renderable -- Convert to base64. imgData <- Char.readFile filename @@ -47,3 +45,23 @@ -- Rendering hint. diagram :: Diagram Cairo -> Diagram Cairo diagram = id + +instance (b ~ Cairo, v ~ V2, s ~ Double, m ~ Any) + => ManuallySizeable (QDiagram a v s m) where + withSizeSpec spec renderable = ManuallySized renderable imgWidth imgHeight + where + aspect = width renderable / height renderable + V2 imgWidth imgHeight = case getSpec spec of + V2 (Just w) (Just h) -> V2 w h + V2 (Just w) Nothing -> V2 w (w/aspect) + V2 Nothing (Just h) -> V2 (aspect*h) h + V2 Nothing Nothing -> (defaultDiagonal / sqrt (1 + aspect^2)) + *^ V2 aspect 1 + -- w^2 + h^2 = defaultDiagonal^2 / (1+aspect^2) + -- * (aspect^2 + 1) + -- = defaultDiagonal^2 + -- w/h = aspect/1 = aspect + defaultDiagonal = 500 + +instance IHaskellDisplay (QDiagram Cairo V2 Double Any) where + display = display . withSizeSpec (mkSizeSpec2D Nothing Nothing) diff --git a/IHaskell/Display/Diagrams/Animation.hs b/IHaskell/Display/Diagrams/Animation.hs --- a/IHaskell/Display/Diagrams/Animation.hs +++ b/IHaskell/Display/Diagrams/Animation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} module IHaskell.Display.Diagrams.Animation (animation) where @@ -11,15 +12,16 @@ import Diagrams.Backend.CmdLine (DiagramOpts(..), mainRender) import IHaskell.Display +import IHaskell.Display.Diagrams.ImgSize -instance IHaskellDisplay (QAnimation Cairo V2 Double Any) where +instance IHaskellDisplay (ManuallySized (QAnimation Cairo V2 Double Any)) where display renderable = do gif <- animationData renderable return $ Display [html $ ""] -animationData :: Animation Cairo V2 Double -> IO String -animationData renderable = do +animationData :: ManuallySized (Animation Cairo V2 Double) -> IO String +animationData (ManuallySized renderable imgWidth imgHeight) = do switchToTmpDir -- Generate the frames @@ -29,14 +31,6 @@ timediff = 100 `div` ceiling fps :: Int frameSet = map (\x -> (x # bg white, timediff)) frames - -- Compute width and height. - let shape = activeStart animAdjusted - w = width shape - h = height shape - aspect = w / h - imgHeight = 300 - imgWidth = aspect * imgHeight - -- Write the image. let filename = ".ihaskell-diagram.gif" diagOpts = DiagramOpts @@ -54,3 +48,26 @@ -- Rendering hint. animation :: Animation Cairo V2 Double -> Animation Cairo V2 Double animation = id + +instance (b ~ Cairo, v ~ V2, s ~ Double, m ~ Any) + => ManuallySizeable (QAnimation b v s m) where + withSizeSpec spec renderable = ManuallySized renderable imgWidth imgHeight + where + fps = 30 + shape = activeStart $ animEnvelope' fps renderable + aspect = width shape / height shape + V2 imgWidth imgHeight = case getSpec spec of + V2 (Just w) (Just h) -> V2 w h + V2 (Just w) Nothing -> V2 w (w/aspect) + V2 Nothing (Just h) -> V2 (aspect*h) h + V2 Nothing Nothing -> (defaultDiagonal / sqrt (1 + aspect^2)) + *^ V2 aspect 1 + -- w^2 + h^2 = defaultDiagonal^2 / (1+aspect^2) + -- * (aspect^2 + 1) + -- = defaultDiagonal^2 + -- w/h = aspect/1 = aspect + defaultDiagonal = 500 + + +instance IHaskellDisplay (QAnimation Cairo V2 Double Any) where + display = display . withSizeSpec (mkSizeSpec2D Nothing Nothing) diff --git a/IHaskell/Display/Diagrams/ImgSize.hs b/IHaskell/Display/Diagrams/ImgSize.hs new file mode 100644 --- /dev/null +++ b/IHaskell/Display/Diagrams/ImgSize.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveFunctor, DeriveGeneric #-} + +module IHaskell.Display.Diagrams.ImgSize where + +import GHC.Generics (Generic) +import Diagrams.Prelude (SizeSpec, mkSizeSpec2D, V2) + +data ManuallySized a = ManuallySized + { contentToDisplay :: a + , imgManualWidth :: Double + , imgManualHeight :: Double + } deriving (Show, Functor, Generic) + +class ManuallySizeable a where + withSizeSpec :: SizeSpec V2 Double -> a -> ManuallySized a + +withImgWidth :: ManuallySizeable a => Int -> a -> ManuallySized a +withImgWidth imgWidth = withSizeSpec $ mkSizeSpec2D (Just $ fromIntegral imgWidth) + Nothing + +withImgHeight :: ManuallySizeable a => Int -> a -> ManuallySized a +withImgHeight imgHeight = withSizeSpec $ mkSizeSpec2D Nothing + (Just $ fromIntegral imgHeight) + diff --git a/ihaskell-diagrams.cabal b/ihaskell-diagrams.cabal --- a/ihaskell-diagrams.cabal +++ b/ihaskell-diagrams.cabal @@ -7,7 +7,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.3.1.1 +version: 0.3.2.1 -- A short (one-line) description of the package. synopsis: IHaskell display instances for diagram types @@ -52,6 +52,7 @@ -- Modules included in this library but not exported. other-modules: IHaskell.Display.Diagrams.Animation + IHaskell.Display.Diagrams.ImgSize -- Other library packages from which modules are imported. build-depends: base >=4.6 && <5,