WIP: trigger implementation

lib/Patat/Eval.hs

@@ -24,7 +24,6 @@ import           Data.Maybe                     (maybeToList)
 import qualified Data.Text                      as T
 import qualified Data.Text.IO                   as T
 import           Patat.Eval.Internal
-import           Patat.Presentation.Instruction
 import           Patat.Presentation.Internal
 import           Patat.Presentation.Syntax
 import           System.Exit                    (ExitCode (..))
@@ -63,46 +62,40 @@ type ExtractEvalM a = StateT VarGen (Writer (HMS.HashMap Var EvalBlock)) a
 evalSlide :: EvalSettingsMap -> Slide -> ExtractEvalM Slide
 evalSlide settings slide = case slideContent slide of
     TitleSlide _ _ -> pure slide
-    ContentSlide instrs0 -> do
-        instrs1 <- traverse (evalInstruction settings) (toList instrs0)
-        pure slide {slideContent = ContentSlide . fromList $ concat instrs1}
-
-
---------------------------------------------------------------------------------
-evalInstruction
-    :: EvalSettingsMap -> Instruction Block
-    -> ExtractEvalM [Instruction Block]
-evalInstruction settings instr = case instr of
-    Pause         -> pure [Pause]
-    ModifyLast i  -> map ModifyLast <$> evalInstruction settings i
-    Append []     -> pure [Append []]
-    Append blocks -> concat <$> traverse (evalBlock settings) blocks
-    Delete        -> pure [Delete]
+    ContentSlide blocks -> do
+        blocks1 <- traverse (evalBlock settings) blocks
+        pure slide {slideContent = ContentSlide $ concat blocks1}
 
 
 --------------------------------------------------------------------------------
 evalBlock
     :: EvalSettingsMap -> Block
-    -> ExtractEvalM [Instruction Block]
+    -> ExtractEvalM [Block]
 evalBlock settings orig@(CodeBlock attr@(_, classes, _) txt)
     | [s@EvalSettings {..}] <- lookupSettings classes settings = do
         var <- state freshVar
         tell $ HMS.singleton var $ EvalBlock s attr txt Nothing
         pure $ case (evalFragment, evalReplace) of
-            (False, True) -> [Append [VarBlock var]]
-            (False, False) -> [Append [orig, VarBlock var]]
+            (False, True) -> [VarBlock var]
+            (False, False) -> [orig, VarBlock var]
             (True, True) ->
+                [orig, VarBlock var]
+                {- TODO: Pause and delete
                 [ Append [orig], Pause
                 , Delete, Append [VarBlock var]
                 ]
+                -}
             (True, False) ->
+                [orig, VarBlock var]
+                {- TODO: Pause
                 [Append [orig], Pause, Append [VarBlock var]]
+                -}
     | _ : _ : _ <- lookupSettings classes settings =
         let msg = "patat eval matched multiple settings for " <>
                 T.intercalate "," classes in
-        pure [Append [CodeBlock attr msg]]
+        pure [CodeBlock attr msg]
 evalBlock _ block =
-    pure [Append [block]]
+    pure [block]
 
 
 --------------------------------------------------------------------------------

lib/Patat/Eval/Internal.hs

@@ -11,7 +11,6 @@ module Patat.Eval.Internal
 import qualified Control.Concurrent.Async       as Async
 import qualified Data.HashMap.Strict            as HMS
 import qualified Data.Text                      as T
-import           Patat.Presentation.Instruction
 import           Patat.Presentation.Settings
 import           Patat.Presentation.Syntax
 import qualified Text.Pandoc                    as Pandoc

lib/Patat/Presentation.hs

@@ -27,7 +27,7 @@ module Patat.Presentation
     ) where
 
 import           Patat.Presentation.Display
-import           Patat.Presentation.Instruction
 import           Patat.Presentation.Interactive
 import           Patat.Presentation.Internal
 import           Patat.Presentation.Read
+import           Patat.Presentation.Syntax

lib/Patat/Presentation/Display.hs

@@ -55,21 +55,24 @@ displayWithBorders (Size rows columns) pres@Presentation {..} f =
                 wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder in
         borders wrappedTitle <> PP.hardline) <>
     f ds <> PP.hardline <>
+    PP.string (show $ dsCounters ds) <> PP.hardline <>
+    PP.string (show $ activeTriggers pres) <> PP.hardline <>
     PP.goToLine (rows - 2) <>
     borders (PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space) <>
     PP.hardline
   where
     -- Get terminal width/title
-    (sidx, _) = pActiveFragment
-    settings  = activeSettings pres
-    ds        = DisplaySettings
+    (sidx, fidx) = pActiveFragment
+    settings     = activeSettings pres
+    ds           = DisplaySettings
         { dsSize          = canvasSize
         , dsMargins       = margins settings
         , dsWrap          = fromMaybe NoWrap $ psWrap settings
         , dsTabStop       = maybe 4 A.unFlexibleNum $ psTabStop settings
         , dsTheme         = fromMaybe Theme.defaultTheme (psTheme settings)
         , dsSyntaxMap     = pSyntaxMap
         , dsResolve       = \var -> fromMaybe [] $ HMS.lookup var pVars
+        , dsCounters      = triggersToCounters $ take fidx $ activeTriggers pres
         }
 
     -- Compute title.
@@ -118,14 +121,13 @@ displayPresentation size pres@Presentation {..} =
         Just (ActiveTitle block) -> DisplayDoc $
             displayWithBorders size pres $ \ds ->
                 let auto = Margins {mTop = Auto, mRight = Auto, mLeft = Auto} in
-                prettyFragment ds {dsMargins = auto} $ Fragment [block]
-
+                prettyFragment ds {dsMargins = auto} [block]
   where
     -- Check if the fragment consists of "just a single image".  Discard
     -- headers.
-    onlyImage (Fragment (Header{} : bs)) = onlyImage (Fragment bs)
-    onlyImage (Fragment bs) = case bs of
-        [Figure _ bs']                 -> onlyImage (Fragment bs')
+    onlyImage (Header{} : bs) = onlyImage bs
+    onlyImage bs = case bs of
+        [Figure _ bs']                 -> onlyImage bs'
         [Para [Image _ _ (target, _)]] -> Just target
         _                              -> Nothing
 
@@ -176,8 +178,8 @@ dumpPresentation pres@Presentation {..} =
 
 
 --------------------------------------------------------------------------------
-prettyFragment :: DisplaySettings -> Fragment -> PP.Doc
-prettyFragment ds (Fragment blocks) = vertical $
+prettyFragment :: DisplaySettings -> [Block] -> PP.Doc
+prettyFragment ds blocks = vertical $
     PP.vcat (map (horizontal . prettyBlock ds) blocks) <>
     case prettyReferences ds blocks of
         []   -> mempty
@@ -323,7 +325,11 @@ prettyBlock ds (LineBlock inliness) =
 
 prettyBlock ds (Figure _attr blocks) = prettyBlocks ds blocks
 
+prettyBlock ds (Fragmented w fragment) = prettyBlocks ds $
+    fragmentToBlocks (dsCounters ds) w fragment
+
 prettyBlock ds (VarBlock var) = prettyBlocks ds $ dsResolve ds var
+
 prettyBlock _ (SpeakerNote _) = mempty
 prettyBlock _ (Config _) = mempty
 

lib/Patat/Presentation/Display/Internal.hs

@@ -8,7 +8,7 @@ module Patat.Presentation.Display.Internal
 --------------------------------------------------------------------------------
 import           Patat.Presentation.Internal (Margins)
 import           Patat.Presentation.Settings (Wrap)
-import           Patat.Presentation.Syntax   (Block, Var)
+import           Patat.Presentation.Syntax   (Block, Counters, Var)
 import qualified Patat.PrettyPrint           as PP
 import           Patat.Size                  (Size)
 import qualified Patat.Theme                 as Theme
@@ -24,6 +24,7 @@ data DisplaySettings = DisplaySettings
     , dsTheme     :: !Theme.Theme
     , dsSyntaxMap :: !Skylighting.SyntaxMap
     , dsResolve   :: !(Var -> [Block])
+    , dsCounters  :: !Counters
     }
 
 

lib/Patat/Presentation/Fragment.hs

@@ -8,70 +8,112 @@
 module Patat.Presentation.Fragment
     ( FragmentSettings (..)
 
-    , fragmentInstructions
+    , fragmentPresentation
     , fragmentBlocks
     , fragmentBlock
     ) where
 
 import           Data.List                      (intersperse, intercalate)
-import           Patat.Presentation.Instruction
+import qualified Data.Set as S
+import Control.Monad.State
+import Data.Traversable (for)
+import Data.Maybe (fromMaybe)
+import Data.Foldable (toList)
 import           Patat.Presentation.Syntax
+import           Patat.Presentation.Internal
 import           Prelude
 
+fragmentPresentation :: Presentation -> Presentation
+fragmentPresentation presentation =
+    let (pres, varGen) = runState work (pVarGen presentation) in
+    pres {pVarGen = varGen}
+  where
+    work = do
+        slides <- traverse fragmentSlide (pSlides presentation)
+        pure presentation {pSlides = slides}
+
+    fragmentSlide slide = case slideContent slide of
+        TitleSlide   _ _     -> pure slide
+        ContentSlide blocks0 -> do
+            blocks1 <- fragmentBlocks fragmentSettings blocks0
+            pure slide {slideContent = ContentSlide blocks1}
+
+    settings = pSettings presentation
+    fragmentSettings = FragmentSettings
+        { fsIncrementalLists = fromMaybe False (psIncrementalLists settings)
+        }
+
 data FragmentSettings = FragmentSettings
     { fsIncrementalLists :: !Bool
     } deriving (Show)
 
-fragmentInstructions
-    :: FragmentSettings
-    -> Instructions Block -> Instructions Block
-fragmentInstructions fs = fromList . concatMap fragmentInstruction . toList
+type FragmentM = State VarGen
+
+splitOnThreeDots :: [Block] -> [[Block]]
+splitOnThreeDots blocks = case break (== threeDots) blocks of
+    (pre, _ : post) -> [pre] ++ splitOnThreeDots post
+    (pre, [])       -> [pre]
   where
-    fragmentInstruction Pause = [Pause]
-    fragmentInstruction (Append []) = [Append []]
-    fragmentInstruction (Append xs) = fragmentBlocks fs xs
-    fragmentInstruction Delete = [Delete]
-    fragmentInstruction (ModifyLast f) = map ModifyLast $ fragmentInstruction f
+    threeDots = Para $ intersperse Space $ replicate 3 (Str ".")
 
 fragmentBlocks
-    :: FragmentSettings -> [Block] -> [Instruction Block]
-fragmentBlocks = concatMap . fragmentBlock
+    :: FragmentSettings -> [Block] -> FragmentM [Block]
+fragmentBlocks fs blocks = case splitOnThreeDots blocks of
+    [] -> pure []
+    [_] -> concat <$> traverse (fragmentBlock fs) blocks
+    sections0@(_ : _) -> do
+        counterID <- CounterID <$> state freshVar
+        sections1 <- traverse (fragmentBlocks fs) sections0
+        let pauses = length sections1 - 1
+            triggers = case sections1 of
+                [] -> replicate pauses counterID
+                (sh : st) -> blocksTriggers sh ++
+                    [c | s <- st, c <- counterID : blocksTriggers s]
+        pure $ pure $ Fragmented (FragmentWrapper concat) $ Fragment2
+            counterID
+            triggers
+            [(S.fromList [i .. pauses], s) | (i, s) <- zip [0 ..] sections1]
 
+fragmentBlock :: FragmentSettings -> Block -> FragmentM [Block]
+fragmentBlock _fs (Para inlines) = pure [Para inlines]
+{-
 fragmentBlock :: FragmentSettings -> Block -> [Instruction Block]
 fragmentBlock _fs block@(Para inlines)
     | inlines == threeDots = [Pause]
     | otherwise            = [Append [block]]
   where
     threeDots = intersperse Space $ replicate 3 (Str ".")
+-}
 
 fragmentBlock fs (BulletList bs0) =
-    fragmentList fs (fsIncrementalLists fs) BulletList bs0
+    fragmentList2 fs (fsIncrementalLists fs) BulletList bs0
 
 fragmentBlock fs (OrderedList attr bs0) =
-    fragmentList fs (fsIncrementalLists fs) (OrderedList attr) bs0
+    fragmentList2 fs (fsIncrementalLists fs) (OrderedList attr) bs0
 
 fragmentBlock fs (BlockQuote [BulletList bs0]) =
-    fragmentList fs (not $ fsIncrementalLists fs) BulletList bs0
+    fragmentList2 fs (not $ fsIncrementalLists fs) BulletList bs0
 
 fragmentBlock fs (BlockQuote [OrderedList attr bs0]) =
-    fragmentList fs (not $ fsIncrementalLists fs) (OrderedList attr) bs0
-
-fragmentBlock _ block@(BlockQuote {})     = [Append [block]]
-
-fragmentBlock _ block@(Header {})         = [Append [block]]
-fragmentBlock _ block@(Plain {})          = [Append [block]]
-fragmentBlock _ block@(CodeBlock {})      = [Append [block]]
-fragmentBlock _ block@(RawBlock {})       = [Append [block]]
-fragmentBlock _ block@(DefinitionList {}) = [Append [block]]
-fragmentBlock _ block@(Table {})          = [Append [block]]
-fragmentBlock _ block@(Div {})            = [Append [block]]
-fragmentBlock _ block@HorizontalRule      = [Append [block]]
-fragmentBlock _ block@(LineBlock {})      = [Append [block]]
-fragmentBlock _ block@(Figure {})         = [Append [block]]
-fragmentBlock _ block@(VarBlock {})       = [Append [block]]
-fragmentBlock _ block@(SpeakerNote {})    = [Append [block]]
-fragmentBlock _ block@(Config {})         = [Append [block]]
+    fragmentList2 fs (not $ fsIncrementalLists fs) (OrderedList attr) bs0
+
+fragmentBlock _ block@(BlockQuote {})     = pure [block]
 
+fragmentBlock _ block@(Header {})         = pure [block]
+fragmentBlock _ block@(Plain {})          = pure [block]
+fragmentBlock _ block@(CodeBlock {})      = pure [block]
+fragmentBlock _ block@(RawBlock {})       = pure [block]
+fragmentBlock _ block@(DefinitionList {}) = pure [block]
+fragmentBlock _ block@(Table {})          = pure [block]
+fragmentBlock _ block@(Div {})            = pure [block]
+fragmentBlock _ block@HorizontalRule      = pure [block]
+fragmentBlock _ block@(LineBlock {})      = pure [block]
+fragmentBlock _ block@(Figure {})         = pure [block]
+fragmentBlock _ block@(VarBlock {})       = pure [block]
+fragmentBlock _ block@(SpeakerNote {})    = pure [block]
+fragmentBlock _ block@(Config {})         = pure [block]
+
+{-
 fragmentList
     :: FragmentSettings      -- ^ Global settings
     -> Bool                  -- ^ Fragment THIS list?
@@ -94,3 +136,23 @@ fragmentList fs fragmentThisList constructor items =
         Append [] :
         -- Modify this new item to add the content.
         map ModifyLast (fragmentBlocks fs item)
+-}
+
+fragmentList2
+    :: FragmentSettings      -- ^ Global settings
+    -> Bool                  -- ^ Fragment THIS list?
+    -> ([[Block]] -> Block)  -- ^ List constructor
+    -> [[Block]]             -- ^ List items
+    -> FragmentM [Block]     -- ^ Resulting list
+fragmentList2 fs fragmentThisList constructor items0 = do
+    items1 <- traverse (fragmentBlocks fs) items0
+    case fragmentThisList of
+        False -> pure [constructor items1]
+        True -> do
+            counterID <- CounterID <$> state freshVar
+            let triggers = [c | s <- items1, c <- counterID : blocksTriggers s]
+                pauses   = length items1
+            pure $ pure $ Fragmented (FragmentWrapper (pure . constructor)) $ Fragment2
+                counterID
+                triggers
+                [(S.fromList [i .. pauses], s) | (i, s) <- zip [1 ..] items1]

lib/Patat/Presentation/Internal.hs

@@ -22,7 +22,6 @@
 
     , Slide (..)
     , SlideContent (..)
-    , Instruction.Fragment (..)
     , Index
 
     , getSlide
@@ -32,6 +31,7 @@
     , activeFragment
     , activeSpeakerNotes
     , activeVars
+    , activeTriggers
 
     , getSettings
     , activeSettings
@@ -50,10 +50,10 @@
 import           Data.Maybe                     (fromMaybe)
 import           Data.Sequence.Extended         (Seq)
 import qualified Data.Sequence.Extended         as Seq
+import Data.Foldable (toList)
 import           Patat.EncodingFallback         (EncodingFallback)
 import qualified Patat.Eval.Internal            as Eval
 import qualified Patat.Presentation.Comments    as Comments
-import qualified Patat.Presentation.Instruction as Instruction
 import           Patat.Presentation.Settings
 import           Patat.Presentation.Syntax
 import           Patat.Size
@@ -81,8 +81,8 @@
     , pActiveFragment   :: !Index
     , pSyntaxMap        :: !Skylighting.SyntaxMap
     , pEvalBlocks       :: !Eval.EvalBlocks
-    , pVarGen           :: !Instruction.VarGen
-    , pVars             :: !(HMS.HashMap Instruction.Var [Block])
+    , pVarGen           :: !VarGen
+    , pVars             :: !(HMS.HashMap Var [Block])
     }
 
 
@@ -117,7 +117,7 @@
 
 --------------------------------------------------------------------------------
 data SlideContent
-    = ContentSlide (Instruction.Instructions Block)
+    = ContentSlide [Block]
     | TitleSlide   Int [Inline]
     deriving (Show)
 
@@ -135,13 +135,16 @@
 --------------------------------------------------------------------------------
 numFragments :: Slide -> Int
 numFragments slide = case slideContent slide of
-    ContentSlide instrs -> Instruction.numFragments instrs
+    ContentSlide instrs ->
+        -- Instruction.numFragments instrs
+        let blocks = toList instrs in
+        1 + length (blocksTriggers blocks)
     TitleSlide _ _      -> 1
 
 
 --------------------------------------------------------------------------------
 data ActiveFragment
-    = ActiveContent Instruction.Fragment
+    = ActiveContent [Block]
     | ActiveTitle Block
     deriving (Show)
 
@@ -149,16 +152,12 @@
 --------------------------------------------------------------------------------
 activeFragment :: Presentation -> Maybe ActiveFragment
 activeFragment presentation = do
     let (sidx, fidx) = pActiveFragment presentation
     slide <- getSlide sidx presentation
     pure $ case slideContent slide of
         TitleSlide lvl is -> ActiveTitle $
             Header lvl Pandoc.nullAttr is
-        ContentSlide instrs -> ActiveContent $
-            Instruction.renderFragment resolve $
-            Instruction.beforePause fidx instrs
-  where
-    resolve var = fromMaybe [] $ HMS.lookup var (pVars presentation)
+        ContentSlide blocks -> ActiveContent blocks
 
 
 --------------------------------------------------------------------------------
@@ -170,18 +169,27 @@
 
 
 --------------------------------------------------------------------------------
-activeVars :: Presentation -> HS.HashSet Instruction.Var
+activeVars :: Presentation -> HS.HashSet Var
 activeVars presentation = fromMaybe HS.empty $ do
     let (sidx, fidx) = pActiveFragment presentation
+        counters = triggersToCounters $ take fidx $ activeTriggers presentation
     slide <- getSlide sidx presentation
     case slideContent slide of
         TitleSlide _ _ -> Nothing
-        ContentSlide instrs -> pure $
-            variables $ Instruction.unFragment $
-            Instruction.renderFragment resolve $
-            Instruction.beforePause fidx instrs
-  where
-    resolve _ = []
+        ContentSlide blocks -> pure $ variables $
+            blocksApplyFragments counters blocks
+
+
+--------------------------------------------------------------------------------
+-- TODO: its weird??
+-- currently it returns all triggers, not just the necessary ones
+activeTriggers :: Presentation -> [CounterID]
+activeTriggers presentation = fromMaybe [] $ do
+    let (sidx, _) = pActiveFragment presentation
+    slide <- getSlide sidx presentation
+    case slideContent slide of
+        TitleSlide   _ _    -> Nothing
+        ContentSlide blocks -> pure $ blocksTriggers blocks
 
 
 --------------------------------------------------------------------------------
@@ -209,5 +217,5 @@
 
 
 --------------------------------------------------------------------------------
-updateVar :: Instruction.Var -> [Block] -> Presentation -> Presentation
+updateVar :: Var -> [Block] -> Presentation -> Presentation
 updateVar var blocks pres = pres {pVars = HMS.insert var blocks $ pVars pres}

lib/Patat/Presentation/Read.hs

@@ -32,7 +32,6 @@ import qualified Patat.EncodingFallback         as EncodingFallback
 import qualified Patat.Eval                     as Eval
 import qualified Patat.Presentation.Comments    as Comments
 import           Patat.Presentation.Fragment
-import qualified Patat.Presentation.Instruction as Instruction
 import           Patat.Presentation.Internal
 import           Patat.Presentation.Syntax
 import           Patat.Transition               (parseTransitionSettings)
@@ -146,7 +145,7 @@ pandocToPresentation pVarGen pFilePath pEncodingFallback pSettings pSyntaxMap
         case psTransition (slideSettings <> pSettings) of
             Nothing -> pure Nothing
             Just ts -> Just <$> parseTransitionSettings ts
-    return Presentation {..}
+    return $ fragmentPresentation $ Presentation {..}
 
 
 --------------------------------------------------------------------------------
@@ -209,19 +208,8 @@ pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> Seq.Seq Slide
 pandocToSlides settings (Pandoc.Pandoc _meta pblocks) =
     let blocks       = fromPandocBlocks pblocks
         slideLevel   = fromMaybe (detectSlideLevel blocks) (psSlideLevel settings)
-        unfragmented = splitSlides slideLevel blocks
-        fragmented   = map fragmentSlide unfragmented in
-    Seq.fromList fragmented
-  where
-    fragmentSlide slide = case slideContent slide of
-        TitleSlide   _ _     -> slide
-        ContentSlide instrs0 ->
-            let instrs1 = fragmentInstructions fragmentSettings instrs0 in
-            slide {slideContent = ContentSlide instrs1}
-
-    fragmentSettings = FragmentSettings
-        { fsIncrementalLists = fromMaybe False (psIncrementalLists settings)
-        }
+        unfragmented = splitSlides slideLevel blocks in
+    Seq.fromList unfragmented
 
 
 --------------------------------------------------------------------------------
@@ -257,8 +245,7 @@ splitSlides slideLevel blocks0
             sns  = Comments.SpeakerNotes [s | SpeakerNote s <- bs0]
             cfgs = concatCfgs [cfg | Config cfg <- bs0]
         guard $ not $ null bs1  -- Never create empty slides
-        pure $ Slide sns cfgs $ ContentSlide $
-            Instruction.fromList [Instruction.Append bs1]
+        pure $ Slide sns cfgs $ ContentSlide bs1
 
     splitAtRules blocks = case break isHorizontalRule blocks of
         (xs, [])           -> mkContentSlide xs

lib/Patat/Presentation/Syntax.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE OverloadedStrings          #-}
@@ -21,11 +24,30 @@
     , isComment
 
     , variables
+
+    , CounterID (..)
+    , blocksTriggers
+    , blocksApplyFragments
+    , Counters
+    , fragmentToBlocks
+    , triggersToCounters
+
+    , FragmentWrapper (..)
+    , Fragment2 (..)
     ) where
 
+import           Control.Monad.State
+import Control.Monad.Identity (runIdentity)
 import           Control.Monad.Writer        (Writer, execWriter, tell)
 import           Data.Hashable               (Hashable)
 import qualified Data.HashSet                as HS
+import Control.Monad (guard)
+import Data.Maybe (fromMaybe)
+import           Data.List                   (foldl')
+import           Data.List.NonEmpty          (NonEmpty)
+import qualified Data.Map                    as M
+import           Data.Monoid                 (Sum (..))
+import qualified Data.Set                    as S
 import qualified Data.Text                   as T
 import qualified Data.Text.Encoding          as T
 import           Data.Traversable            (for)
@@ -73,6 +95,7 @@
     | Figure !Pandoc.Attr ![Block]
     | Div !Pandoc.Attr ![Block]
     -- Our own extensions:
+    | Fragmented !FragmentWrapper !(Fragment2 [Block])
     | VarBlock !Var
     | SpeakerNote !T.Text
     | Config !(Either String PresentationSettings)
@@ -139,6 +162,7 @@
             <*> traverse (traverse blocks) trows
         Figure attr xs -> Figure attr <$> blocks xs
         Div attr xs -> Div attr <$> blocks xs
+        Fragmented w fragments -> Fragmented w <$> traverse blocks fragments
         b@(VarBlock _var) -> pure b
         b@(SpeakerNote _txt) -> pure b
         b@(Config _cfg) -> pure b
@@ -269,3 +293,64 @@
             VarBlock var -> tell $ HS.singleton var
             _            -> pure ()
         pure [b]
+
+newtype CounterID = CounterID Var deriving (Eq, Ord, Show)
+
+-- We can construct a new one by doing a max + 1 over blocks.
+
+-- For each fragment, we can store which counters fire in which order
+data Fragment2 a = Fragment2
+    -- The ID of the counter for this fragment
+    CounterID
+    -- These counters should be fired in this order
+    [CounterID]
+    -- If our counter has any of these values, the block will be visible.
+    [(S.Set Int, a)]
+    deriving (Foldable, Functor, Eq, Show, Traversable)
+
+newtype FragmentWrapper = FragmentWrapper ([[Block]] -> [Block])
+
+instance Show FragmentWrapper where
+    show _ = "FragmentWrapper"
+
+instance Eq FragmentWrapper where
+    _ == _ = True
+
+-- This has given us a way to get the top level fragments in a list of blocks
+blocksTriggers :: [Block] -> [CounterID]
+blocksTriggers blocks = concat $
+    execState (dftBlocks visit (pure . pure) blocks) []
+  where
+    visit :: Block -> State [[CounterID]] [Block]
+    visit (Fragmented w fragment) = do
+        modify $ merge fragment
+        pure [Fragmented w fragment]
+    visit block = pure [block]
+
+    merge :: Fragment2 [Block] -> [[CounterID]] -> [[CounterID]]
+    merge (Fragment2 fid triggers _) known
+        | any (fid `elem`) known = known
+        | otherwise              =
+            filter (not . any (`elem` triggers)) known ++ [triggers]
+
+-- If each of those can give us an order, we can calculate a total order
+
+type Counters = M.Map CounterID Int
+
+triggersToCounters :: [CounterID] -> Counters
+triggersToCounters = foldl' (\acc x -> M.insertWith (+) x 1 acc) M.empty
+
+fragmentToBlocks :: Counters -> FragmentWrapper -> Fragment2 [Block] -> [Block]
+fragmentToBlocks counters (FragmentWrapper w) (Fragment2 cid _ sections) = w
+    [ section
+    | (activation, section) <- sections
+    , counter `S.member` activation
+    ]
+  where
+    counter = fromMaybe 0 $ M.lookup cid counters
+
+blocksApplyFragments :: Counters -> [Block] -> [Block]
+blocksApplyFragments counters = runIdentity . dftBlocks visit (pure . pure)
+  where
+    visit (Fragmented w fragment) = pure $ fragmentToBlocks counters w fragment
+    visit block                   = pure [block]

patat.cabal

@@ -86,7 +86,6 @@ Library
     Patat.Presentation.Display.Internal
     Patat.Presentation.Display.Table
     Patat.Presentation.Fragment
-    Patat.Presentation.Instruction
     Patat.Presentation.Interactive
     Patat.Presentation.Internal
     Patat.Presentation.Read