WIP: trigger implementation

lib/Patat/Presentation/Display.hs

@@ -55,21 +55,23 @@ 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.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.
@@ -323,7 +325,11 @@ prettyBlock ds (LineBlock inliness) =
 
 prettyBlock ds (Figure _attr blocks) = prettyBlocks ds blocks
 
+prettyBlock ds (Fragmented fragment) = prettyBlocks ds $ concat $
+    fragmentToBlocks (dsCounters ds) 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

@@ -14,6 +14,7 @@ module Patat.Presentation.Fragment
     ) where
 
 import           Data.List                      (intersperse, intercalate)
+import qualified Data.Set as S
 import           Patat.Presentation.Instruction
 import           Patat.Presentation.Syntax
 import           Prelude
@@ -33,16 +34,40 @@ fragmentInstructions fs = fromList . concatMap fragmentInstruction . toList
     fragmentInstruction Delete = [Delete]
     fragmentInstruction (ModifyLast f) = map ModifyLast $ fragmentInstruction f
 
+splitOnThreeDots :: [Block] -> [[Block]]
+splitOnThreeDots blocks = case break (== threeDots) blocks of
+    (pre, _ : post) -> [pre] ++ splitOnThreeDots post
+    (pre, [])       -> [pre]
+  where
+    threeDots = Para $ intersperse Space $ replicate 3 (Str ".")
+
 fragmentBlocks
     :: FragmentSettings -> [Block] -> [Instruction Block]
-fragmentBlocks = concatMap . fragmentBlock
+fragmentBlocks fs blocks = case splitOnThreeDots blocks of
+    [] -> []
+    [_] -> concatMap (fragmentBlock fs) blocks
+    sections@(sh : st) ->
+        pure $ Append $ pure $ Fragmented $ Fragment2
+            counterID
+            triggers
+            [(S.fromList [i .. pauses], s) | (i, s) <- zip [0 ..] sections]
+      where
+        counterID = freshCounterID $ blocksFreshCounterID blocks
+        pauses    = length sections - 1
+        triggers  = blocksTriggers sh ++
+            [c | s <- st, c <- counterID : blocksTriggers s]
 
+
+fragmentBlock :: FragmentSettings -> Block -> [Instruction Block]
+fragmentBlock _fs (Para inlines) = [Append [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

lib/Patat/Presentation/Instruction.hs

@@ -4,6 +4,8 @@
 --
 -- We do this by modelling a slide as a list of instructions, that manipulate
 -- the contents on a slide in a (for now) very basic way.
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Patat.Presentation.Instruction
     ( Instructions
@@ -27,7 +29,7 @@ import           Data.List                 (foldl')
 import           Patat.Presentation.Syntax
 
 newtype Instructions a = Instructions {unInstructions :: [Instruction a]}
-    deriving (Show)
+    deriving (Functor, Foldable, Show)
 
 -- A smart constructor that guarantees some invariants:
 --
@@ -54,7 +56,7 @@ data Instruction a
     | Delete
     -- Modify the last block with the provided instruction.
     | ModifyLast (Instruction a)
-    deriving (Show)
+    deriving (Functor, Foldable, Show)
 
 isPause :: Instruction a -> Bool
 isPause Pause          = True

lib/Patat/Presentation/Internal.hs

@@ -32,6 +32,7 @@ module Patat.Presentation.Internal
     , activeFragment
     , activeSpeakerNotes
     , activeVars
+    , activeTriggers
 
     , getSettings
     , activeSettings
@@ -50,6 +51,7 @@ import qualified Data.HashSet                   as HS
 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
@@ -135,7 +137,10 @@ getSlide sidx = (`Seq.safeIndex` sidx) . pSlides
 --------------------------------------------------------------------------------
 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
 
 
@@ -184,6 +189,22 @@ activeVars presentation = fromMaybe HS.empty $ do
     resolve _ = []
 
 
+--------------------------------------------------------------------------------
+-- TODO: its weird??
+activeTriggers :: Presentation -> [CounterID]
+activeTriggers presentation = fromMaybe [] $ do
+    let (sidx, fidx) = pActiveFragment presentation
+    slide <- getSlide sidx presentation
+    case slideContent slide of
+        TitleSlide _ _ -> Nothing
+        ContentSlide instrs -> pure $
+            blocksTriggers $ Instruction.unFragment $
+            Instruction.renderFragment resolve $
+            Instruction.beforePause fidx instrs
+  where
+    resolve _ = []
+
+
 --------------------------------------------------------------------------------
 getSettings :: Int -> Presentation -> PresentationSettings
 getSettings sidx pres =

lib/Patat/Presentation/Syntax.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE OverloadedStrings          #-}
@@ -21,11 +24,29 @@ module Patat.Presentation.Syntax
     , isComment
 
     , variables
+
+    , CounterID
+    , freshCounterID
+    , blocksFreshCounterID
+    , blocksTriggers
+    , Counters
+    , fragmentToBlocks
+    , triggersToCounters
+
+    , Fragment2 (..)
     ) where
 
+import           Control.Monad.State
 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 +94,7 @@ data Block
     | Figure !Pandoc.Attr ![Block]
     | Div !Pandoc.Attr ![Block]
     -- Our own extensions:
+    | Fragmented !(Fragment2 [Block])
     | VarBlock !Var
     | SpeakerNote !T.Text
     | Config !(Either String PresentationSettings)
@@ -139,6 +161,7 @@ dftBlocks fb fi = blocks
             <*> traverse (traverse blocks) trows
         Figure attr xs -> Figure attr <$> blocks xs
         Div attr xs -> Div attr <$> blocks xs
+        Fragmented fragments -> Fragmented <$> traverse blocks fragments
         b@(VarBlock _var) -> pure b
         b@(SpeakerNote _txt) -> pure b
         b@(Config _cfg) -> pure b
@@ -269,3 +292,71 @@ variables = execWriter . dftBlocks visit (pure . pure)
             VarBlock var -> tell $ HS.singleton var
             _            -> pure ()
         pure [b]
+
+newtype CounterID = CounterID Int deriving (Eq, Ord, Show)
+
+newtype FreshCounterID = FreshCounterID CounterID deriving (Show)
+
+instance Semigroup FreshCounterID where
+    FreshCounterID (CounterID x) <> FreshCounterID (CounterID y) =
+        FreshCounterID $ CounterID $ max x y
+
+instance Monoid FreshCounterID where
+    mempty = FreshCounterID $ CounterID 0
+
+freshCounterID :: FreshCounterID -> CounterID
+freshCounterID (FreshCounterID (CounterID x)) = CounterID (x + 1)
+
+blocksFreshCounterID :: [Block] -> FreshCounterID
+blocksFreshCounterID = execWriter . dftBlocks visit (pure . pure)
+  where
+    visit :: Block -> Writer FreshCounterID [Block]
+    visit b = do
+        case b of
+            Fragmented (Fragment2 c _ _) -> tell $ FreshCounterID c
+            _                            -> pure ()
+        pure [b]
+
+-- 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)
+
+-- 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 fragment) = do
+        modify $ merge fragment
+        pure [Fragmented 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 -> Fragment2 a -> [a]
+fragmentToBlocks counters (Fragment2 cid _ sections) = do
+    (activation, section) <- sections
+    guard $ counter `S.member` activation
+    pure section
+  where
+    counter = fromMaybe 0 $ M.lookup cid counters