Add a `withAnimFps` for manual animation sample rate specification

ihaskell-display/ihaskell-diagrams/IHaskell/Display/Diagrams.hs

@@ -4,6 +4,7 @@
 module IHaskell.Display.Diagrams
          ( diagram, animation
          , ManuallySized, withSizeSpec, withImgWidth, withImgHeight
+         , ManuallySampled, withAnimFps
          ) where
 
 import qualified Data.ByteString.Char8 as Char

ihaskell-display/ihaskell-diagrams/IHaskell/Display/Diagrams/Animation.hs

 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies                            #-}
+{-# LANGUAGE DeriveFunctor, DeriveGeneric #-}
 
-module IHaskell.Display.Diagrams.Animation (animation) where
+module IHaskell.Display.Diagrams.Animation
+         ( animation
+         , ManuallySampled, withAnimFps
+         ) where
 
 import qualified Data.Text as T
 import qualified Data.ByteString.Char8 as CBS
 
+import           GHC.Generics (Generic)
+import           Data.Maybe (fromMaybe)
 import           Diagrams.Prelude
 import           Diagrams.Backend.Cairo
 import           Diagrams.Backend.Cairo.CmdLine (GifOpts(..))
@@ -14,21 +20,38 @@ import           Diagrams.Backend.CmdLine (DiagramOpts(..), mainRender)
 import           IHaskell.Display
 import           IHaskell.Display.Diagrams.ImgSize
 
-instance IHaskellDisplay (ManuallySized (QAnimation Cairo V2 Double Any)) where
+
+data ManuallySampled a = ManuallySampled
+    { contentToSample :: a
+    , signalManualSampleRate :: Maybe Rational
+    } deriving (Show, Functor, Generic)
+
+class ManuallySamplable a where
+  withSamplingSpec :: Maybe Rational -> a -> ManuallySampled a
+
+
+defaultFps = 30
+
+withAnimFps :: ManuallySamplable a => Rational -> a -> ManuallySampled a
+withAnimFps fps = withSamplingSpec (Just fps)
+
+
+instance IHaskellDisplay (ManuallySized (ManuallySampled (QAnimation Cairo V2 Double Any))) where
   display renderable = do
     gif <- animationData renderable
     return $ Display [html $ "<img src=\"data:image/gif;base64,"
                              ++ gif ++ "\" />"]
 
-animationData :: ManuallySized (Animation Cairo V2 Double) -> IO String
-animationData (ManuallySized renderable imgWidth imgHeight) = do
+
+animationData :: ManuallySized (ManuallySampled (Animation Cairo V2 Double)) -> IO String
+animationData (ManuallySized (ManuallySampled renderable fps) imgWidth imgHeight) = do
   switchToTmpDir
 
   -- Generate the frames
-  let fps = 30
-      animAdjusted = animEnvelope' fps renderable
-      frames = simulate fps animAdjusted
-      timediff = 100 `div` ceiling fps :: Int
+  let actualFps = fromMaybe defaultFps fps
+      animAdjusted = animEnvelope' actualFps renderable
+      frames = simulate actualFps animAdjusted
+      timediff = 100 `div` ceiling actualFps :: Int
       frameSet = map (\x -> (x # bg white, timediff)) frames
 
   -- Write the image.
@@ -45,29 +68,70 @@ animationData (ManuallySized renderable imgWidth imgHeight) = do
   imgData <- CBS.readFile filename
   return . T.unpack . base64 $ imgData
 
+
 -- Rendering hint.
 animation :: Animation Cairo V2 Double -> Animation Cairo V2 Double
 animation = id
 
+
+getImgSize renderable sizeSpec fps = out
+  where
+    actualFps = fromMaybe defaultFps fps
+    shape = activeStart $ animEnvelope' actualFps renderable
+    aspect = width shape / height shape
+    out = case getSpec sizeSpec 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 (b ~ Cairo, v ~ V2, s ~ Double, m ~ Any)
+              => ManuallySamplable (QAnimation b v s m) where
+  withSamplingSpec fps renderable = ManuallySampled renderable fps
+
+instance (b ~ Cairo, v ~ V2, s ~ Double, m ~ Any)
+              => ManuallySamplable (ManuallySized (QAnimation b v s m)) where
+  withSamplingSpec fps sizedRenderable = ManuallySampled sizedRenderable fps
+
 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
+      fps = Nothing
+      V2 imgWidth imgHeight = getImgSize renderable spec fps
+
+instance (b ~ Cairo, v ~ V2, s ~ Double, m ~ Any)
+              => ManuallySizeable (ManuallySampled (QAnimation b v s m)) where
+  withSizeSpec spec (ManuallySampled renderable fps) = out
+    where
+      out = ManuallySized (ManuallySampled renderable fps) w h
+      V2 w h = getImgSize renderable spec fps
 
 
 instance IHaskellDisplay (QAnimation Cairo V2 Double Any) where
+  display = display . withSizeSpec (mkSizeSpec2D Nothing Nothing) . withSamplingSpec fps
+    where
+      fps = Nothing
+
+instance IHaskellDisplay (ManuallySized (QAnimation Cairo V2 Double Any)) where
+  display (ManuallySized renderable w h) = out
+    where
+      fps = Nothing
+      sizeSpec = mkSizeSpec2D (Just w) (Just h)
+      out = display . withSizeSpec sizeSpec $ withSamplingSpec fps renderable
+
+instance IHaskellDisplay (ManuallySampled (QAnimation Cairo V2 Double Any)) where
   display = display . withSizeSpec (mkSizeSpec2D Nothing Nothing)
+
+instance IHaskellDisplay (ManuallySampled (ManuallySized (QAnimation Cairo V2 Double Any))) where
+  display (ManuallySampled (ManuallySized renderable w h) fps) = out
+    where
+      sizeSpec = mkSizeSpec2D (Just w) (Just h)
+      out = display . withSizeSpec sizeSpec $ withSamplingSpec fps renderable
\ No newline at end of file