merge

ejconlon · Feb 16, 2024 · 75847e9 · 75847e9
1 parent 82eef67
commit 75847e9
Show file tree

Hide file tree

Showing 2 changed files with 42 additions and 7 deletions.
diff --git a/minipat/src/Minipat/Stream.hs b/minipat/src/Minipat/Stream.hs
@@ -21,7 +21,7 @@ module Minipat.Stream
   , streamFilter
   , streamInnerBind
   , streamOuterBind
-  , streamMixBind
+  , streamMixedBind
   , streamRun
   , streamAdjust
   , streamSeq
@@ -61,8 +61,9 @@ import Minipat.Time
   , Cycle (..)
   , CycleDelta (..)
   , CycleTime (..)
+  , MergeStrat (..)
   , Span (..)
-  , arcIntersect
+  , arcMerge
   , arcTimeMapMono
   , spanSplit
   , spanTimeMapMono
@@ -152,7 +153,7 @@ instance Applicative Stream where
   (<*>) = ap
 
 instance Monad Stream where
-  (>>=) = streamMixBind
+  (>>=) = streamMixedBind
 
 -- | '(<>)' is parallel composition of streams
 instance Semigroup (Stream a) where
@@ -178,14 +179,32 @@ streamBindWith g pa f = Stream $ \arc ->
         let tb = unStream (f a) ac
         in  tapeWholeMapMono (g wh) tb
 
+streamBind :: MergeStrat -> Stream a -> (a -> Stream b) -> Stream b
+streamBind = streamBindWith . arcMerge
+
 streamInnerBind :: Stream a -> (a -> Stream b) -> Stream b
-streamInnerBind = streamBindWith (\_ x -> x)
+streamInnerBind = streamBind MergeStratInner
 
 streamOuterBind :: Stream a -> (a -> Stream b) -> Stream b
-streamOuterBind = streamBindWith const
+streamOuterBind = streamBind MergeStratOuter
+
+streamMixedBind :: Stream a -> (a -> Stream b) -> Stream b
+streamMixedBind = streamBind MergeStratMixed
+
+streamApplyWith :: (Maybe Arc -> Maybe Arc -> Maybe Arc) -> (a -> b -> c) -> Stream a -> Stream b -> Stream c
+streamApplyWith = error "TODO"
+
+streamApply :: MergeStrat -> (a -> b -> c) -> Stream a -> Stream b -> Stream c
+streamApply = streamApplyWith . arcMerge
+
+streamInnerApply :: (a -> b -> c) -> Stream a -> Stream b -> Stream c
+streamInnerApply = streamApply MergeStratInner
+
+streamOuterApply :: (a -> b -> c) -> Stream a -> Stream b -> Stream c
+streamOuterApply = streamApply MergeStratOuter
 
-streamMixBind :: Stream a -> (a -> Stream b) -> Stream b
-streamMixBind = streamBindWith (liftA2 arcIntersect)
+streamMixedApply :: (a -> b -> c) -> Stream a -> Stream b -> Stream c
+streamMixedApply = streamApply MergeStratMixed
 
 streamRun :: Stream a -> Arc -> [Ev a]
 streamRun pa arc = tapeToList (unStream pa arc)

diff --git a/minipat/src/Minipat/Time.hs b/minipat/src/Minipat/Time.hs
@@ -13,6 +13,8 @@ module Minipat.Time
   , arcIntersect
   , arcMid
   , arcTimeMapMono
+  , MergeStrat (..)
+  , arcMerge
   , Span (..)
   , spanCover
   , spanSplit
@@ -84,6 +86,20 @@ arcMid (Arc s e) = cycTimeMid s e
 arcTimeMapMono :: (CycleTime -> CycleTime) -> Arc -> Arc
 arcTimeMapMono f (Arc s e) = Arc (f s) (f e)
 
+-- | Strategy for merging arcs
+data MergeStrat
+  = MergeStratInner
+  | MergeStratOuter
+  | MergeStratMixed
+  deriving stock (Eq, Ord, Show, Enum, Bounded)
+
+-- | Merges arcs according to the given strategy
+arcMerge :: MergeStrat -> Maybe Arc -> Maybe Arc -> Maybe Arc
+arcMerge = \case
+  MergeStratInner -> (\_ x -> x)
+  MergeStratOuter -> const
+  MergeStratMixed -> liftA2 arcIntersect
+
 data Span = Span
   { spanActive :: !Arc
   , spanWhole :: !(Maybe Arc)