move innerJoin, <*/*> and definition of patternify and friends up to …

…pattern, get tests running again

src/Sound/Tidal/ParseBP.hs

@@ -1,5 +1,10 @@
-{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor, GADTs, StandaloneDeriving #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-}
 
 module Sound.Tidal.ParseBP where
@@ -23,31 +28,34 @@ module Sound.Tidal.ParseBP where
     along with this library.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
-import           Control.Applicative ()
-import qualified Control.Exception as E
+import           Control.Applicative                    ()
+import qualified Control.Exception                      as E
 import           Data.Colour
 import           Data.Colour.Names
-import           Data.Functor.Identity (Identity)
-import           Data.List (intercalate)
+import           Data.Functor.Identity                  (Identity)
+import           Data.List                              (intercalate)
 import           Data.Ratio
-import           Data.Typeable (Typeable)
-import           GHC.Exts ( IsString(..) )
+import           Data.Typeable                          (Typeable)
+import           GHC.Exts                               (IsString (..))
 import           Text.Parsec.Error
-import           Text.ParserCombinators.Parsec
-import           Text.ParserCombinators.Parsec.Language ( haskellDef )
-import qualified Text.ParserCombinators.Parsec.Token as P
 import qualified Text.Parsec.Prim
+import           Text.ParserCombinators.Parsec
+import           Text.ParserCombinators.Parsec.Language (haskellDef)
+import qualified Text.ParserCombinators.Parsec.Token    as P
 
-import           Sound.Tidal.Types
-import           Sound.Tidal.Signal.Base
-import           Sound.Tidal.Signal.Random (rand, chooseBy, _degradeByUsing)
+import           Sound.Tidal.Chords                     (Modifier (..),
+                                                         chordTable,
+                                                         chordToPatSeq)
 import           Sound.Tidal.Pattern
+import           Sound.Tidal.Signal.Base
+import           Sound.Tidal.Signal.Random              (_degradeByUsing,
+                                                         chooseBy, rand)
+import           Sound.Tidal.Types
+import           Sound.Tidal.Utils                      (fromRight)
 import           Sound.Tidal.Value
-import           Sound.Tidal.Chords (Modifier(..), chordTable, chordToPatSeq)
-import           Sound.Tidal.Utils (fromRight)
 
 data TidalParseError = TidalParseError {parsecError :: ParseError,
-                                        code :: String
+                                        code        :: String
                                        }
   deriving (Eq, Typeable)
 
@@ -157,7 +165,7 @@ toPat = \case
    TPat_Euclid n k s thing -> doEuclid (toPat n) (toPat k) (toPat s) (toPat thing)
    TPat_Stack xs -> stack $ map toPat xs
    TPat_Silence -> silence
-   TPat_EnumFromTo a b -> mixJoin $ (fromTo <$> toPat a) `appLeft` toPat b
+   TPat_EnumFromTo a b -> mixJoin $ (fromTo <$> toPat a) `sigAppLeft` toPat b
    -- TPat_EnumFromTo a b -> unwrap $ fromTo <$> toPat a <*> toPat b
    TPat_Polyrhythm mSteprate ps -> stack $ map adjust_speed pats
      where adjust_speed (sz, pat) = fast ((/sz) <$> steprate) pat
@@ -174,34 +182,34 @@ toPat = \case
 
 resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Signal a)
 resolve_tpat (TPat_Seq xs) = resolve_seq xs
-resolve_tpat a = (1, toPat a)
+resolve_tpat a             = (1, toPat a)
 
 resolve_seq :: (Enumerable a, Parseable a) => [TPat a] -> (Rational, Signal a)
 resolve_seq xs = (total_size, timeCat sized_pats)
   where sized_pats = map (toPat <$>) $ resolve_size xs
         total_size = sum $ map fst sized_pats
 
 resolve_size :: [TPat a] -> [(Rational, TPat a)]
-resolve_size [] = []
+resolve_size []                       = []
 resolve_size ((TPat_Elongate r p):ps) = (r, p):resolve_size ps
-resolve_size ((TPat_Repeat n p):ps) = replicate n (1,p) ++ resolve_size ps
-resolve_size (p:ps) = (1,p):resolve_size ps
+resolve_size ((TPat_Repeat n p):ps)   = replicate n (1,p) ++ resolve_size ps
+resolve_size (p:ps)                   = (1,p):resolve_size ps
 
 
 steps_tpat :: (Show a) => TPat a -> (Rational, String)
 steps_tpat (TPat_Seq xs) = steps_seq xs
-steps_tpat a = (1, tShow a)
+steps_tpat a             = (1, tShow a)
 
 steps_seq :: (Show a) => [TPat a] -> (Rational, String)
 steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r,s) -> "(" ++ show r ++ ", " ++ s ++ ")") sized_pats) ++ "]")
   where sized_pats = steps_size xs
         total_size = sum $ map fst sized_pats
 
 steps_size :: Show a => [TPat a] -> [(Rational, String)]
-steps_size [] = []
+steps_size []                       = []
 steps_size ((TPat_Elongate r p):ps) = (r, tShow p):steps_size ps
-steps_size ((TPat_Repeat n p):ps) = replicate n (1, tShow p) ++ steps_size ps
-steps_size (p:ps) = (1,tShow p):steps_size ps
+steps_size ((TPat_Repeat n p):ps)   = replicate n (1, tShow p) ++ steps_size ps
+steps_size (p:ps)                   = (1,tShow p):steps_size ps
 
 parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Signal a)
 parseBP s = toPat <$> parseTPat s
@@ -211,7 +219,7 @@ parseBP_E s = toE parsed
   where
     parsed = parseTPat s
     -- TODO - custom error
-    toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s}
+    toE (Left e)   = E.throw $ TidalParseError {parsecError = e, code = s}
     toE (Right tp) = toPat tp
 
 parseTPat :: Parseable a => String -> Either ParseError (TPat a)

src/Sound/Tidal/Pattern.hs

@@ -5,6 +5,8 @@ module Sound.Tidal.Pattern where
 
 import           Sound.Tidal.Types
 
+import           Prelude           hiding ((*>), (<*))
+
 -- ************************************************************ --
 -- Pattern class
 
@@ -17,14 +19,6 @@ class (Functor p, Applicative p, Monad p) => Pattern p where
   silence :: p a
   atom :: a -> p a
   stack :: [p a] -> p a
-  -- patternify the first parameter
-  _patternify :: (a -> p b -> p c) -> (p a -> p b -> p c)
-  -- patternify the first two parameters
-  _patternify_p_p :: (a -> b -> p c -> p d) -> (p a -> p b -> p c -> p d)
-  -- patternify the first but not the second parameters
-  _patternify_p_n :: (a -> b -> p c -> p d) -> (p a -> b -> p c -> p d)
-  -- patternify the first three parameters
-  _patternify_p_p_p :: (a -> b -> c -> p d -> p e) -> (p a -> p b -> p c -> p d -> p e)
   _appAlign :: (a -> p b -> p c) -> Align (p a) (p b) -> p c
   rev :: p a -> p a
   _ply :: Time -> p a-> p a
@@ -41,6 +35,11 @@ class (Functor p, Applicative p, Monad p) => Pattern p where
   collect :: Eq a => p a -> p [a]
   uncollect :: p [a] -> p a
   _pressBy :: Time -> p a -> p a
+  innerJoin :: p (p a) -> p a
+  (<*) :: p (a -> b) -> p a -> p b
+  (*>) :: p (a -> b) -> p a -> p b
+
+infixl 4 <*, *>
 
 -- ************************************************************ --
 -- Alignment
@@ -80,6 +79,25 @@ powA = _opA (^)
 powfA :: Floating a => Pattern p => Align (p a) (p a) -> p a
 powfA = _opA (**)
 
+-- ************************************************************ --
+-- Patternification
+
+-- patternify the first parameter
+_patternify :: Pattern p => (a -> p b -> p c) -> (p a -> p b -> p c)
+_patternify f apat pat                 = innerJoin $ (`f` pat) <$> apat
+
+-- patternify the first two parameters
+_patternify_p_p :: (Pattern p) => (a -> b -> p c -> p d) -> (p a -> p b -> p c -> p d)
+_patternify_p_p f apat bpat pat        = innerJoin $ (\a b -> f a b pat) <$> apat <* bpat
+
+-- patternify the first but not the second parameters
+-- _patternify_p_n :: Pattern p => (a -> b -> p c -> p d) -> (p a -> b -> p c -> p d)
+_patternify_p_n f apat b pat           = innerJoin $ (\a -> f a b pat) <$> apat
+
+-- patternify the first three parameters
+-- _patternify_p_p_p :: Pattern p => (a -> b -> c -> p d -> p e) -> (p a -> p b -> p c -> p d -> p e)
+_patternify_p_p_p f apat bpat cpat pat = innerJoin $ (\a b c -> f a b c pat) <$> apat <* bpat <* cpat
+
 -- ************************************************************ --
 -- Other functions common to Signals and Sequences
 

src/Sound/Tidal/Scales.hs

@@ -18,11 +18,12 @@ module Sound.Tidal.Scales (scale, scaleList, scaleTable, getScale) where
     along with this library.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
-import Prelude hiding ((<*), (*>))
-import Data.Maybe
-import Sound.Tidal.Types
-import Sound.Tidal.Signal.Base ((<*))
-import Sound.Tidal.Utils
+import           Data.Maybe
+import           Prelude                 hiding ((*>), (<*))
+import           Sound.Tidal.Pattern     ((<*))
+import           Sound.Tidal.Signal.Base
+import           Sound.Tidal.Types
+import           Sound.Tidal.Utils
 
 -- five notes scales
 minPent :: Fractional a => [a]

src/Sound/Tidal/Sequence.hs

@@ -3,7 +3,7 @@
 -- (c) Alex McLean, Aravind Mohandas and contributors 2022
 -- Shared under the terms of the GNU Public License v3.0
 
-module Sound.Tidal.Sequence2 where
+module Sound.Tidal.Sequence where
 
 import           Sound.Tidal.Time
 -- import Sound.Tidal.Value
@@ -53,6 +53,10 @@ instance Pattern Sequence where
   silence = gap 1
   atom = step 1
   stack = Stack
+  innerJoin = join -- TODO - is this right?
+  (<*) = (<*>) -- TODO - are these right? Probably not..
+  (*>) = (<*>)
+
 --   -- patternify the first parameter
 --   _patternify :: (a -> p b -> p c) -> (p a -> p b -> p c)
 --   -- patternify the first two parameters
@@ -115,8 +119,9 @@ step :: Time -> a -> Sequence a
 step t v = Atom t 0 0 $ Just v
 
 seqTake :: Time -> Sequence a -> Maybe (Sequence a)
+seqTake 0 _ = Just $ gap 0
 seqTake t (a@(Atom d i o v)) | t > d = Nothing
-                             | otherwise = Just $ Atom t i o v
+                             | otherwise = Just $ Atom t i (max 0 $ d - t) v
 -- Return nothing if you ask for too much
 seqTake t (Stack ss) = Stack <$> (sequence $ map (seqTake t) ss)
 seqTake t (Cat ss) = Cat <$> (sequence $ loop t ss)

src/Sound/Tidal/Show.hs

@@ -40,8 +40,8 @@ prettyRatio r | denominator r == 1 = show $ numerator r
               | otherwise = show (numerator r) ++ "/" ++ show (denominator r)
 
 instance (Show a) => Show (Sequence a) where
-  show (Atom d _ _ Nothing) = "~" ++ ">" ++ prettyRatio d
-  show (Atom d i o (Just v)) = show v ++ ">" ++ prettyRatio d ++ showio
+  show (Atom d _ _ Nothing) = "~" ++ "×" ++ prettyRatio d
+  show (Atom d i o (Just v)) = show v ++ "×" ++ prettyRatio d ++ showio
     where showio | i == 0 && o == 0 = ""
                  | otherwise = "(" ++ prettyRatio i ++ "," ++ prettyRatio o ++ ")"
   show (Cat xs) = "[" ++ (intercalate " " (map show xs)) ++ "]"

src/Sound/Tidal/Signal/Base.hs

@@ -62,10 +62,9 @@ instance Pattern Signal where
   uncollect = sigUncollect
   euclid  = sigEuclid
   _euclid = _sigEuclid
-  _patternify f apat pat                 = innerJoin $ (`f` pat) <$> apat
-  _patternify_p_p f apat bpat pat        = innerJoin $ (\a b -> f a b pat) <$> apat <* bpat
-  _patternify_p_n f apat b pat           = innerJoin $ (\a -> f a b pat) <$> apat
-  _patternify_p_p_p f apat bpat cpat pat = innerJoin $ (\a b c -> f a b c pat) <$> apat <* bpat <* cpat
+  innerJoin = sigInnerJoin
+  (<*) = sigAppLeft
+  (*>) = sigAppRight
   toSignal = id
   _pressBy = _sigPressBy
   _appAlign  = _sigAppAlign
@@ -86,12 +85,12 @@ _sigAppAlign f (Align a _ _) = error $ "Alignment " ++ show a ++ " not implement
 
 instance Applicative Signal where
   pure = atom -- TODO - would this be better as 'steady'?
-  (<*>) = app
+  (<*>) = sigApp
 
 -- | Apply a pattern of values to a pattern of functions, given a
 -- function to merge the 'whole' timearcs
-app :: Signal (a -> b) -> Signal a -> Signal b
-app patf patv = Signal f
+sigApp :: Signal (a -> b) -> Signal a -> Signal b
+sigApp patf patv = Signal f
     where f s = concatMap (\ef -> mapMaybe (combine ef) $ query patv s) $ query patf s
           combine ef ev = do new_active <- maybeSect (active ef) (active ev)
                              return $ Event {metadata = metadata ef <> metadata ev,
@@ -102,8 +101,8 @@ app patf patv = Signal f
 
 -- | Alternative definition of <*>, which takes the wholes from the
 -- pattern of functions (unrelated to the <* in Prelude)
-(<*), appLeft :: Signal (a -> b) -> Signal a -> Signal b
-(<*) patf patv = Signal f
+sigAppLeft :: Signal (a -> b) -> Signal a -> Signal b
+sigAppLeft patf patv = Signal f
   where f s = concatMap (\ef -> mapMaybe (combine ef) $ query patv (s {sArc = wholeOrActive ef})
                         ) $ query patf s
         combine ef ev = do new_active <- maybeSect (active ef) (active ev)
@@ -112,12 +111,11 @@ app patf patv = Signal f
                                            active = new_active,
                                            value = value ef $ value ev
                                           }
-appLeft = (<*)
 
 -- | Alternative definition of <*>, which takes the wholes from the
 -- pattern of functions (unrelated to the <* in Prelude)
-(*>), appRight :: Signal (a -> b) -> Signal a -> Signal b
-(*>) patf patv = Signal f
+sigAppRight :: Signal (a -> b) -> Signal a -> Signal b
+sigAppRight patf patv = Signal f
   where f s = concatMap (\ev -> mapMaybe (combine ev) $ query patf (s {sArc = wholeOrActive ev})
                         ) $ query patv s
         combine ev ef = do new_active <- maybeSect (active ef) (active ev)
@@ -127,10 +125,6 @@ appLeft = (<*)
                                            value = value ef $ value ev
                                           }
 
-appRight = (*>)
-
-infixl 4 <*, *>
-
 -- ************************************************************ --
 
 instance Monoid (Signal a) where
@@ -153,8 +147,8 @@ mixJoin s = bind s id
 innerBind :: Signal a -> (a -> Signal b) -> Signal b
 innerBind = bindWhole (flip const)
 
-innerJoin :: Signal (Signal a) -> Signal a
-innerJoin s = innerBind s id
+sigInnerJoin :: Signal (Signal a) -> Signal a
+sigInnerJoin s = innerBind s id
 
 outerBind :: Signal a -> (a -> Signal b) -> Signal b
 outerBind = bindWhole (const)

src/Sound/Tidal/Signal/Compose.hs

@@ -8,14 +8,15 @@
 
 module Sound.Tidal.Signal.Compose where
 
-import Prelude hiding ((<*), (*>))
-import Control.Monad (forM)
-import Data.Bits
+import           Control.Monad           (forM)
+import           Data.Bits
+import           Prelude                 hiding ((*>), (<*))
 
-import qualified Data.Map.Strict as Map
+import qualified Data.Map.Strict         as Map
 
-import Sound.Tidal.Types
-import Sound.Tidal.Signal.Base
+import           Sound.Tidal.Pattern     ((*>), (<*))
+import           Sound.Tidal.Signal.Base
+import           Sound.Tidal.Types
 
 -- ************************************************************ --
 -- Hack to allow 'union' to be used on any value
@@ -38,19 +39,19 @@ opMix f a b = f <$> a <*> b
 
 opIn :: (a -> b -> c) -> Signal a -> Signal b -> Signal c
 opIn f a b = f <$> a <* b
-  
+
 opOut :: (a -> b -> c) -> Signal a -> Signal b -> Signal c
 opOut f a b = f <$> a *> b
 
 opSqueeze :: (a -> b -> c) -> Signal a -> Signal b -> Signal c
 opSqueeze f a b = squeezeJoin $ fmap (\a -> fmap (\b -> f a b)  b) a
-  
+
 opSqueezeOut :: (a -> b -> c) -> Signal a -> Signal b -> Signal c
 opSqueezeOut f pata patb = squeezeJoin $ fmap (\a -> fmap (\b -> f b a)  pata) patb
 
 opTrig :: (a -> b -> c) -> Signal a -> Signal b -> Signal c
 opTrig f a b = trigJoin $ fmap (\a -> fmap (\b -> f a b)  b) a
-  
+
 opTrigzero :: (a -> b -> c) -> Signal a -> Signal b -> Signal c
 opTrigzero f a b = trigzeroJoin $ fmap (\a -> fmap (\b -> f a b)  b) a