fix up binds and applicative

tidal-core/src/Sound/Tidal/Compose.hs

@@ -5,7 +5,8 @@
 
 module Sound.Tidal.Compose where
 
-import qualified Data.Map.Strict   as Map
+import qualified Data.Map.Strict     as Map
+import           Sound.Tidal.Pattern (flexBind)
 import           Sound.Tidal.Types
 
 -- ************************************************************ --
@@ -22,6 +23,8 @@ instance Unionable a where
 instance {-# OVERLAPPING #-} Unionable ValueMap where
   union = Map.union
 
+liftP2 :: Pattern p => (a -> b -> c) -> (p a -> p b -> p c)
+liftP2 op apat bpat = apat `flexBind` \a -> op a <$> bpat
+
 (#) :: (Pattern p, Unionable a) => p a -> p a -> p a
-(#) apat bpat = apat `bind` \a -> bpat `bind` \b -> return (union b a)
-  where bind = patBind apat
+(#) = liftP2 union

tidal-core/src/Sound/Tidal/InstanceHacks.hs

@@ -8,6 +8,7 @@ import           Control.Applicative  (Applicative (..))
 import           Prelude              hiding (Applicative (..))
 
 import qualified Data.Map.Strict      as Map
+import           Sound.Tidal.Compose  (liftP2)
 import           Sound.Tidal.Sequence ()
 import           Sound.Tidal.Signal   ()
 import           Sound.Tidal.Types
@@ -38,15 +39,15 @@ instance Eq (Signal a) where
   (==) = noOv "(==)"
 
 instance Ord a => Ord (Signal a) where
-  min = liftA2 min
-  max = liftA2 max
+  min = liftP2 min
+  max = liftP2 max
   compare = noOv "compare"
   (<=) = noOv "(<=)"
 
 instance Num a => Num (Signal a) where
   negate      = fmap negate
-  (+)         = liftA2 (+)
-  (*)         = liftA2 (*)
+  (+)         = liftP2 (+)
+  (*)         = liftP2 (*)
   fromInteger = pure . fromInteger
   abs         = fmap abs
   signum      = fmap signum
@@ -65,10 +66,10 @@ instance (Num a, Ord a) => Real (Signal a) where
   toRational = noOv "toRational"
 
 instance (Integral a) => Integral (Signal a) where
-  quot          = liftA2 quot
-  rem           = liftA2 rem
-  div           = liftA2 div
-  mod           = liftA2 mod
+  quot          = liftP2 quot
+  rem           = liftP2 rem
+  div           = liftP2 div
+  mod           = liftP2 mod
   toInteger     = noOv "toInteger"
   x `quotRem` y = (x `quot` y, x `rem` y)
   x `divMod`  y = (x `div`  y, x `mod` y)
@@ -114,15 +115,15 @@ instance (RealFloat a) => RealFloat (Signal a) where
   isDenormalized = noOv "isDenormalized"
   isNegativeZero = noOv "isNegativeZero"
   isIEEE         = noOv "isIEEE"
-  atan2          = liftA2 atan2
+  atan2          = liftP2 atan2
 
 -- ************************************************************ --
 -- Sequences as numbers
 
 instance Num a => Num (Sequence a) where
   negate      = fmap negate
-  (+)         = liftA2 (+)
-  (*)         = liftA2 (*)
+  (+)         = liftP2 (+)
+  (*)         = liftP2 (*)
   fromInteger = pure . fromInteger
   abs         = fmap abs
   signum      = fmap signum
@@ -141,10 +142,10 @@ instance (Num a, Ord a) => Real (Sequence a) where
   toRational = noOv "toRational"
 
 instance (Integral a) => Integral (Sequence a) where
-  quot          = liftA2 quot
-  rem           = liftA2 rem
-  div           = liftA2 div
-  mod           = liftA2 mod
+  quot          = liftP2 quot
+  rem           = liftP2 rem
+  div           = liftP2 div
+  mod           = liftP2 mod
   toInteger     = noOv "toInteger"
   x `quotRem` y = (x `quot` y, x `rem` y)
   x `divMod`  y = (x `div`  y, x `mod` y)
@@ -190,5 +191,5 @@ instance (RealFloat a) => RealFloat (Sequence a) where
   isDenormalized = noOv "isDenormalized"
   isNegativeZero = noOv "isNegativeZero"
   isIEEE         = noOv "isIEEE"
-  atan2          = liftA2 atan2
+  atan2          = liftP2 atan2
 

tidal-core/src/Sound/Tidal/Pattern.hs

@@ -52,6 +52,9 @@ pf <* px = pf `innerBind` \f -> px `innerBind` \x -> pure $ f x
 pf *> px = pf `outerBind` \f -> px `outerBind` \x -> pure $ f x
 infixl 4 <*, *>
 
+flexBind :: Pattern p => p b -> (b -> p c) -> p c
+flexBind a b = (patBind a) a b
+
 -- ************************************************************ --
 -- Transformations common to Signals and Sequences
 

tidal-core/src/Sound/Tidal/Sequence.hs

@@ -23,7 +23,8 @@ instance Monad Sequence where
 
 instance Applicative Sequence where
   pure = step 1
-  pf <*> px = pf >>= \f -> px >>= \x -> pure $ f x
+  -- pf <*> px = pf >>= \f -> px >>= \x -> pure $ f x
+  pf <*> px = pf >>= (<$> px)
 
 instance Pattern Sequence where
   withTime f _ pat = withAtomTime f pat
@@ -40,6 +41,13 @@ instance Pattern Sequence where
   innerJoin = seqInnerJoin
   squeezeJoin = seqSqueezeJoin
 
+  out = setSeqBind SeqOut
+  mix = setSeqBind SeqMix
+  -- trig = setAlignment
+  -- trig0 = setAlignment
+  squeeze = setAlignment SqueezeIn
+  squeezeOut = setAlignment SqueezeOut
+
   patBind = getSeqBind
   patAlign = getSeqAlign
 

tidal-core/src/Sound/Tidal/Signal.hs

@@ -14,24 +14,34 @@ import           Sound.Tidal.Time
 import           Sound.Tidal.Types
 
 instance Monad Signal where
-  (>>=) = sigBindWith $ liftA2 sect
+  -- (>>=) a b = (getSigBind a) a b
+  (>>=) = mixBind
   return = pure
 
 -- Define applicative from monad
 instance Applicative Signal where
   pure v = Signal mempty $ \state -> map (\span -> Event mempty (Just $ timeToCycle $ aBegin span) span v) $ splitSpans $ sSpan state
-  pf <*> px = pf >>= \f -> px >>= \x -> pure $ f x
+--   pf <*> px = pf >>= \f -> px >>= \x -> pure $ f x
+  pf <*> px = pf >>= (<$> px)
 
 instance Pattern Signal where
   -- We always work with signals as if they have a duration of 1
   -- cycle, even though successive cycles very often differ
   duration _ = 1
   withTime fa fb pat = withEventTime fa $ withQueryTime fb pat
   -- | Alternative binds/joins
-  innerBind = sigBindWith $ flip const
-  outerBind = sigBindWith const
+  mixBind = sigBindWith $ liftA2 sect
+  innerBind = sigBindWith const
+  outerBind = sigBindWith $ flip const
   squeezeJoin = sigSqueezeJoin
 
+  out = setSigBind SigOut
+  mix = setSigBind SigMix
+  trig = setSigBind SigTrig
+  trig0 = setSigBind SigTrig0
+  squeeze = setSigBind SigSqueeze
+  squeezeOut = setSigBind SigSqueezeOut
+
   patBind = getSigBind
   -- Signals are always aligned cycle-by-cycle
   patAlign a b = (a,b)
@@ -63,16 +73,20 @@ instance Pattern Signal where
 
 getSigBind :: Signal a -> Signal b -> (b -> Signal c) -> Signal c
 getSigBind pat = case (signalBind pat) of
-                   SigIn       -> innerBind
-                   SigOut      -> outerBind
-                   SigSqueeze  -> squeezeBind
-                   SigTrig     -> trigBind
-                   SigTrigzero -> trigzeroBind
-                   SigMix      -> (>>=)
+                   SigIn         -> innerBind
+                   SigOut        -> outerBind
+                   SigSqueeze    -> squeezeBind
+                   SigSqueezeOut -> squeezeOutBind
+                   SigTrig       -> trigBind
+                   SigTrig0      -> trig0Bind
+                   SigMix        -> mixBind
   where signalBind :: Signal a -> SignalBind
         signalBind (Signal {sigMetadata = SignalMetadata (Just bind)}) = bind
         signalBind _                                                   = SigIn
 
+setSigBind :: SignalBind -> Signal a -> Signal a
+setSigBind bind pat = pat {sigMetadata = SignalMetadata (Just bind)}
+
 -- instance Signalable (Signal a) a where toSig = id
 -- instance Signalable a a where toSig = pure
 
@@ -168,6 +182,12 @@ sigSqueezeJoin pp = pp {query = q}
              return (Event (iMetadata <> oMetadata) w' p' v)
 
 
+-- | Like @sigSqueezeJoin@, but outer cycles of the outer patterns are
+-- compressed to fit the timespan of the inner whole
+
+-- TODO!
+-- sigSqueezeOutJoin :: Signal (Signal a) -> Signal a
+
 -- Flatterns patterns of patterns, by retriggering/resetting inner
 -- patterns at onsets of outer pattern events
 _trigTimeJoin :: (Time -> Time) -> Signal (Signal a) -> Signal a
@@ -187,11 +207,12 @@ trigJoin = _trigTimeJoin cyclePos
 trigBind :: Signal a -> (a -> Signal b) -> Signal b
 trigBind pat f = trigJoin $ fmap f pat
 
-trigzeroJoin :: Signal (Signal a) -> Signal a
-trigzeroJoin = _trigTimeJoin id
+trig0Join :: Signal (Signal a) -> Signal a
+trig0Join = _trigTimeJoin id
+
+trig0Bind :: Signal a -> (a -> Signal b) -> Signal b
+trig0Bind pat f = trig0Join $ fmap f pat
 
-trigzeroBind :: Signal a -> (a -> Signal b) -> Signal b
-trigzeroBind pat f = trigzeroJoin $ fmap f pat
 
 {- | Plays a portion of a signal, specified by start and duration
 The new resulting signal is played over the time period of the original signal:

tidal-core/src/Sound/Tidal/Types.hs

@@ -41,24 +41,38 @@ instance forall a t. Applicative t => Applicable t (t a) (a) where toA = id
 
 -- | A type class for patterns
 class (Functor p, Applicative p, Monad p) => Pattern p where
-  {-# MINIMAL (innerBind | innerJoin),
+  {-# MINIMAL (mixBind | mixJoin),
+              (innerBind | innerJoin),
               (outerBind | outerJoin),
               (squeezeBind | squeezeJoin),
+              (squeezeOutBind | squeezeOutJoin),
               patBind, patAlign,
+              out, mix, trig, trig0, squeeze, squeezeOut,
               duration, withTime, cat, timeCat, stack, _early, rev, toSignal,
               withMetadata, silence, _zoomSpan
     #-}
   duration :: p a -> Time
   withTime :: (Time -> Time) -> (Time -> Time) -> p a -> p a
-  innerBind, outerBind, squeezeBind :: p a -> (a -> p b) -> p b
+  mixBind, innerBind, outerBind, squeezeBind, squeezeOutBind :: p a -> (a -> p b) -> p b
+  mixBind pat f = mixJoin $ fmap f pat
   innerBind pat f = innerJoin $ fmap f pat
   outerBind pat f = outerJoin $ fmap f pat
   squeezeBind pat f = squeezeJoin $ fmap f pat
+  squeezeOutBind pat f = squeezeOutJoin $ fmap f pat
 
-  innerJoin, outerJoin, squeezeJoin :: p (p a) -> p a
+  mixJoin, innerJoin, outerJoin, squeezeJoin, squeezeOutJoin :: p (p a) -> p a
+  mixJoin pat = innerBind pat id
   innerJoin pat = innerBind pat id
   outerJoin pat = outerBind pat id
   squeezeJoin pat = squeezeBind pat id
+  squeezeOutJoin pat = squeezeOutBind pat id
+
+  out :: p a -> p a
+  mix :: p a -> p a
+  trig :: p a -> p a
+  trig0 :: p a -> p a
+  squeeze :: p a -> p a
+  squeezeOut :: p a -> p a
 
   patBind :: p a -> p b -> (b -> p c) -> p c
   patAlign :: p a -> p b -> (p a, p b)
@@ -291,8 +305,9 @@ data SignalBind = SigIn
                 | SigMix
                 -- Signals allow some alignment at bind time
                 | SigSqueeze
+                | SigSqueezeOut
                 | SigTrig
-                | SigTrigzero
+                | SigTrig0
   deriving (Eq, Ord, Show, Generic)
 instance NFData SignalBind