From 24d070b0e42f031b7455cb451632ceb19ec6c6b4 Mon Sep 17 00:00:00 2001
From: George Thomas <georgefsthomas@gmail.com>
Date: Mon, 30 Oct 2023 18:52:22 +0000
Subject: [PATCH] feat: Use transparent background on animations

Note that we use `DisposalRestoreBackground` in encoding the GIF, whereas previously we indirectly used `diagrams-rasterific`'s default, `DisposalAny`. While that worked with the default black background, retaining it now would mean that we would see previous frames remaining in the background rather than disappearing.

Signed-off-by: George Thomas <georgefsthomas@gmail.com>
---
 flake.nix                       |  2 --
 primer/primer.cabal             |  1 +
 primer/src/Primer/Primitives.hs | 30 ++++++++++++++++++++----------
 3 files changed, 21 insertions(+), 12 deletions(-)

diff --git a/flake.nix b/flake.nix
index 43dc0e957..1d71dc429 100644
--- a/flake.nix
+++ b/flake.nix
@@ -471,8 +471,6 @@
                     # Disabled, as it doesn't currently build with Nix.
                     #weeder = weederVersion;
 
-                    fourmolu = fourmoluVersion;
-
                     cabal-fmt = "latest";
 
                     #TODO Explicitly requiring tasty-discover shouldn't be necessary - see the commented-out `build-tool-depends` in primer.cabal.
diff --git a/primer/primer.cabal b/primer/primer.cabal
index 590871b8d..33dfec856 100644
--- a/primer/primer.cabal
+++ b/primer/primer.cabal
@@ -118,6 +118,7 @@ library
     , exceptions                   >=0.10.4  && <0.11.0
     , extra                        >=1.7.10  && <1.8.0
     , generic-optics               >=2.0     && <2.3.0
+    , JuicyPixels                  ^>=3.3.8
     , list-t                       >=1.0     && <1.1.0
     , logging-effect               ^>=1.4
     , mmorph                       ^>=1.2.0
diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs
index fc98ce645..fb5c9bad5 100644
--- a/primer/src/Primer/Primitives.hs
+++ b/primer/src/Primer/Primitives.hs
@@ -28,17 +28,24 @@ module Primer.Primitives (
 
 import Foreword hiding (rotate)
 
+import Codec.Picture.ColorQuant (palettizeWithAlpha)
+import Codec.Picture.Gif (
+  GifDisposalMethod (DisposalRestoreBackground),
+  GifEncode (GifEncode),
+  GifLooping (LoopingForever),
+  encodeComplexGifImage,
+ )
 import Control.Monad.Fresh (MonadFresh)
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.ByteString.Base64 qualified as B64
 import Data.Data (Data)
 import Data.Map qualified as M
 import Diagrams.Backend.Rasterific (
-  GifLooping (LoopingForever),
-  defaultPaletteOptions,
-  rasterGif,
+  Options (RasterificOptions),
+  Rasterific (Rasterific),
  )
 import Diagrams.Prelude (
+  Diagram,
   V2 (..),
   circle,
   deg,
@@ -47,6 +54,7 @@ import Diagrams.Prelude (
   mkSizeSpec,
   rect,
   rectEnvelope,
+  renderDia,
   rotate,
   sRGB24,
   translate,
@@ -337,7 +345,7 @@ primFunDef def args = case def of
     -- Since we can only translate a `Picture` expression to an image once it is in normal form,
     -- this guard will only pass when `picture` has no free variables other than `time`.
     [PrimCon () (PrimInt duration), Lam () time picture]
-      | Just frames <- traverse diagramAtTime [0 .. (duration * 100) `div` frameLength] ->
+      | Just (frames :: [Diagram Rasterific]) <- traverse diagramAtTime [0 .. (duration * 100) `div` frameLength] ->
           Right
             $ prim
             $ PrimAnimation
@@ -348,14 +356,16 @@ primFunDef def args = case def of
               -- for unrelated reasons (getting the `Bytestring` without dumping it to a file).
               mempty
               (decodeUtf8 . B64.encode . toS)
-            $ rasterGif @Double
-              (mkSizeSpec $ Just . fromInteger <$> V2 width height)
-              gifLooping
-              defaultPaletteOptions
+            $ encodeComplexGifImage
+            $ GifEncode (fromInteger width) (fromInteger height) Nothing Nothing gifLooping
+            $ flip palettizeWithAlpha DisposalRestoreBackground
             $ map
-              ( (,fromInteger frameLength)
+              ( (fromInteger frameLength,)
+                  . renderDia
+                    Rasterific
+                    (RasterificOptions (mkSizeSpec $ Just . fromInteger <$> V2 width height))
                   . rectEnvelope
-                    (fromInteger <$> mkP2 (width `div` 2) (height `div` 2))
+                    (fromInteger <$> mkP2 (-width `div` 2) (-height `div` 2))
                     (fromInteger <$> V2 width height)
               )
               frames