content: {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
  {-# LANGUAGE TypeFamilies                            #-}
  {-# LANGUAGE DeriveFunctor, DeriveGeneric #-}
  
  module IHaskell.Display.Diagrams.Animation
           ( animation
           , ManuallySampled, withAnimFps
           ) where
  
  import qualified Data.ByteString.Char8 as CBS
  import qualified Data.Text as T
  
  import           GHC.Generics (Generic)
  import           Data.Maybe (fromMaybe)
  import           Diagrams.Prelude
  import           Diagrams.Backend.Cairo
  import           Diagrams.Backend.Cairo.CmdLine (GifOpts(..))
  import           Diagrams.Backend.CmdLine (DiagramOpts(..), mainRender)
  import           System.IO.Temp
  import           System.FilePath ((</>))
  
  import           IHaskell.Display
  import           IHaskell.Display.Diagrams.ImgSize
  
  
  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' Nothing $ "<img src=\"data:image/gif;base64," ++ gif ++ "\" />"]
  
  
  animationData :: ManuallySized (ManuallySampled (Animation Cairo V2 Double)) -> IO String
  animationData (ManuallySized (ManuallySampled renderable fps) imgWidth imgHeight) = do
    -- We should not have to round-trip this ByteString to a temp file.
    -- https://github.com/IHaskell/IHaskell/issues/1248
    withSystemTempDirectory "ihaskell-diagram" $ \tmpdir -> do
  
      let path = tmpdir </> "ihaskell-diagram.gif"
  
      -- Generate the frames
      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.
      let diagOpts = DiagramOpts
            { _width = Just . ceiling $ imgWidth
            , _height = Just . ceiling $ imgHeight
            , _output = path
            }
          gifOpts = GifOpts { _dither = True, _noLooping = False, _loopRepeat = Nothing }
      mainRender (diagOpts, gifOpts) frameSet
  
      -- Convert to ascii represented base64 encoding
      imgData <- CBS.readFile path
      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 = 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
  