tidal-1.9.5: src/Sound/Tidal/Pattern.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-
Pattern.hs - core representation of Tidal patterns
Copyright (C) 2020 Alex McLean and contributors
This library is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library. If not, see <http://www.gnu.org/licenses/>.
-}
module Sound.Tidal.Pattern (module Sound.Tidal.Pattern,
module Sound.Tidal.Time
)
where
import Prelude hiding ((<*), (*>))
import Control.Applicative (liftA2)
import GHC.Generics
import Control.DeepSeq (NFData)
import Control.Monad ((>=>))
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe)
import Data.List (delete, findIndex, (\\))
import Data.Word (Word8)
import Data.Data (Data) -- toConstr
import Data.Typeable (Typeable)
import Data.Fixed (mod')
import Sound.Tidal.Time
------------------------------------------------------------------------
-- * Types
-- | an Arc and some named control values
data State = State {arc :: Arc,
controls :: ValueMap
}
-- | A datatype representing events taking place over time
data Pattern a = Pattern {query :: State -> [Event a]}
deriving (Generic, Functor)
instance NFData a => NFData (Pattern a)
-- type StateMap = Map.Map String (Pattern Value)
type ControlPattern = Pattern ValueMap
-- * Applicative and friends
instance Applicative Pattern where
-- | Repeat the given value once per cycle, forever
pure v = Pattern $ \(State a _) ->
map (\a' -> Event
(Context [])
(Just a')
(sect a a')
v)
$ cycleArcsInArc a
-- | In each of @a <*> b@, @a <* b@ and @a *> b@
-- (using the definitions from this module, not the Prelude),
-- the time structure of the result
-- depends on the structures of both @a@ and @b@.
-- They all result in @Event@s with identical @part@s and @value@s.
-- However, their @whole@s are different.
--
-- For instance, @listToPat [(+1), (+2)] <*> "0 10 100"@
-- gives the following 4-@Event@ cycle:
-- > (0>⅓)|1
-- > (⅓>½)|11
-- > (½>⅔)|12
-- > (⅔>1)|102
-- If we use @<*@ instead, we get this:
-- > (0>⅓)-½|1
-- > 0-(⅓>½)|11
-- > (½>⅔)-1|12
-- > ½-(⅔>1)|102
-- And if we use @*>@, we get this:
-- > (0>⅓)|1
-- > (⅓>½)-⅔|11
-- > ⅓-(½>⅔)|12
-- > (⅔>1)|102
(<*>) = applyPatToPatBoth
-- | Like @<*>@, but the "wholes" come from the left
(<*) :: Pattern (a -> b) -> Pattern a -> Pattern b
(<*) = applyPatToPatLeft
-- | Like @<*>@, but the "wholes" come from the right
(*>) :: Pattern (a -> b) -> Pattern a -> Pattern b
(*>) = applyPatToPatRight
-- | Like @<*>@, but the "wholes" come from the left
(<<*) :: Pattern (a -> b) -> Pattern a -> Pattern b
(<<*) = applyPatToPatSqueeze
infixl 4 <*, *>, <<*
applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPat combineWholes pf px = Pattern q
where q st = catMaybes $ concatMap match $ query pf st
where
match ef@(Event (Context c) _ fPart f) =
map
(\ex@(Event (Context c') _ xPart x) ->
do whole' <- combineWholes (whole ef) (whole ex)
part' <- subArc fPart xPart
return (Event (Context $ c ++ c') whole' part' (f x))
)
(query px $ st {arc = wholeOrPart ef})
applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatBoth pf px = Pattern q
where q st = catMaybes $ (concatMap match $ query pf st) ++ (concatMap matchX $ query (filterAnalog px) st)
where
-- match analog events from pf with all events from px
match ef@(Event _ Nothing fPart _) = map (withFX ef) (query px $ st {arc = fPart}) -- analog
-- match digital events from pf with digital events from px
match ef@(Event _ (Just fWhole) _ _) = map (withFX ef) (query (filterDigital px) $ st {arc = fWhole}) -- digital
-- match analog events from px (constrained above) with digital events from px
matchX ex@(Event _ Nothing fPart _) = map (`withFX` ex) (query (filterDigital pf) $ st {arc = fPart}) -- digital
matchX _ = error "can't happen"
withFX ef ex = do whole' <- subMaybeArc (whole ef) (whole ex)
part' <- subArc (part ef) (part ex)
return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))
applyPatToPatLeft :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatLeft pf px = Pattern q
where q st = catMaybes $ concatMap match $ query pf st
where
match ef = map (withFX ef) (query px $ st {arc = wholeOrPart ef})
withFX ef ex = do let whole' = whole ef
part' <- subArc (part ef) (part ex)
return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))
applyPatToPatRight :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatRight pf px = Pattern q
where q st = catMaybes $ concatMap match $ query px st
where
match ex = map (`withFX` ex) (query pf $ st {arc = wholeOrPart ex})
withFX ef ex = do let whole' = whole ex
part' <- subArc (part ef) (part ex)
return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))
applyPatToPatSqueeze :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatSqueeze pf px = squeezeJoin $ (\f -> f <$> px) <$> pf
-- * Monad and friends
--
-- $monadAndFriends
--
-- Note there are four ways of joining - the default 'unwrap' used by @>>=@, as well
-- as @innerJoin@, @innerJoin@ and @squeezeJoin@.
instance Monad Pattern where
return = pure
p >>= f = unwrap (f <$> p)
-- | Turns a pattern of patterns into a single pattern.
-- (this is actually 'join')
--
-- 1/ For query 'arc', get the events from the outer pattern @pp@
-- 2/ Query the inner pattern using the 'part' of the outer
-- 3/ For each inner event, set the whole and part to be the intersection
-- of the outer whole and part, respectively
-- 4/ Concatenate all the events together (discarding wholes/parts that didn't intersect)
--
-- TODO - what if a continuous pattern contains a discrete one, or vice-versa?
unwrap :: Pattern (Pattern a) -> Pattern a
unwrap pp = pp {query = q}
where q st = concatMap
(\(Event c w p v) ->
mapMaybe (munge c w p) $ query v st {arc = p})
(query pp st)
munge oc ow op (Event ic iw ip v') =
do
w' <- subMaybeArc ow iw
p' <- subArc op ip
return (Event (combineContexts [ic, oc]) w' p' v')
-- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
-- but structure only comes from the inner pattern.
innerJoin :: Pattern (Pattern a) -> Pattern a
innerJoin pp = pp {query = q}
where q st = concatMap
(\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op}
)
(query pp st)
where munge oc (Event ic iw ip v) =
do
p <- subArc (arc st) ip
p' <- subArc p (arc st)
return (Event (combineContexts [ic, oc]) iw p' v)
-- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
-- but structure only comes from the outer pattern.
outerJoin :: Pattern (Pattern a) -> Pattern a
outerJoin pp = pp {query = q}
where q st = concatMap
(\e ->
mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)}
)
(query pp st)
where munge oc ow op (Event ic _ _ v') =
do
p' <- subArc (arc st) op
return (Event (combineContexts [oc, ic]) ow p' v')
-- | Like @unwrap@, but cycles of the inner patterns are compressed to fit the
-- timespan of the outer whole (or the original query if it's a continuous pattern?)
-- TODO - what if a continuous pattern contains a discrete one, or vice-versa?
squeezeJoin :: Pattern (Pattern a) -> Pattern a
squeezeJoin pp = pp {query = q}
where q st = concatMap
(\e@(Event c w p v) ->
mapMaybe (munge c w p) $ query (focusArc (wholeOrPart e) v) st {arc = p}
)
(query pp st)
munge oContext oWhole oPart (Event iContext iWhole iPart v) =
do w' <- subMaybeArc oWhole iWhole
p' <- subArc oPart iPart
return (Event (combineContexts [iContext, oContext]) w' p' v)
_trigJoin :: Bool -> Pattern (Pattern a) -> Pattern a
_trigJoin cycleZero pat_of_pats = Pattern q
where q st =
catMaybes $
concatMap
(\oe@(Event oc (Just jow) op ov) ->
map (\oe@(Event ic (iw) ip iv) ->
do w <- subMaybeArc (Just jow) iw
p <- subArc op ip
return $ Event (combineContexts [ic, oc]) w p iv
)
$ query (((if cycleZero then id else cyclePos) $ start jow) `rotR` ov) st
)
(query (filterDigital pat_of_pats) st)
trigJoin :: Pattern (Pattern a) -> Pattern a
trigJoin = _trigJoin False
trigZeroJoin :: Pattern (Pattern a) -> Pattern a
trigZeroJoin = _trigJoin True
reset :: Pattern Bool -> Pattern a -> Pattern a
reset bp pat = trigJoin $ (\v -> if v then pat else silence) <$> bp
resetTo :: Pattern Rational -> Pattern a -> Pattern a
resetTo bp pat = trigJoin $ (\v -> rotL v pat) <$> bp
restart :: Pattern Bool -> Pattern a -> Pattern a
restart bp pat = trigZeroJoin $ (\v -> if v then pat else silence) <$> bp
restartTo :: Pattern Rational -> Pattern a -> Pattern a
restartTo bp pat = trigZeroJoin $ (\v -> rotL v pat) <$> bp
-- | * Patterns as numbers
noOv :: String -> a
noOv meth = error $ meth ++ ": not supported for patterns"
instance Eq (Pattern a) where
(==) = noOv "(==)"
instance Ord a => Ord (Pattern a) where
min = liftA2 min
max = liftA2 max
compare = noOv "compare"
(<=) = noOv "(<=)"
instance Num a => Num (Pattern a) where
negate = fmap negate
(+) = liftA2 (+)
(*) = liftA2 (*)
fromInteger = pure . fromInteger
abs = fmap abs
signum = fmap signum
instance Enum a => Enum (Pattern a) where
succ = fmap succ
pred = fmap pred
toEnum = pure . toEnum
fromEnum = noOv "fromEnum"
enumFrom = noOv "enumFrom"
enumFromThen = noOv "enumFromThen"
enumFromTo = noOv "enumFromTo"
enumFromThenTo = noOv "enumFromThenTo"
instance Monoid (Pattern a) where
mempty = empty
instance Semigroup (Pattern a) where
(<>) !p !p' = Pattern $ \st -> query p st ++ query p' st
instance (Num a, Ord a) => Real (Pattern a) where
toRational = noOv "toRational"
instance (Integral a) => Integral (Pattern a) where
quot = liftA2 quot
rem = liftA2 rem
div = liftA2 div
mod = liftA2 mod
toInteger = noOv "toInteger"
x `quotRem` y = (x `quot` y, x `rem` y)
x `divMod` y = (x `div` y, x `mod` y)
instance (Fractional a) => Fractional (Pattern a) where
recip = fmap recip
fromRational = pure . fromRational
instance (Floating a) => Floating (Pattern a) where
pi = pure pi
sqrt = fmap sqrt
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
atan = fmap atan
acos = fmap acos
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
atanh = fmap atanh
acosh = fmap acosh
instance (RealFrac a) => RealFrac (Pattern a) where
properFraction = noOv "properFraction"
truncate = noOv "truncate"
round = noOv "round"
ceiling = noOv "ceiling"
floor = noOv "floor"
instance (RealFloat a) => RealFloat (Pattern a) where
floatRadix = noOv "floatRadix"
floatDigits = noOv "floatDigits"
floatRange = noOv "floatRange"
decodeFloat = noOv "decodeFloat"
encodeFloat = ((.).(.)) pure encodeFloat
exponent = noOv "exponent"
significand = noOv "significand"
scaleFloat n = fmap (scaleFloat n)
isNaN = noOv "isNaN"
isInfinite = noOv "isInfinite"
isDenormalized = noOv "isDenormalized"
isNegativeZero = noOv "isNegativeZero"
isIEEE = noOv "isIEEE"
atan2 = liftA2 atan2
instance Num ValueMap where
negate = (applyFIS negate negate id <$>)
(+) = Map.unionWith (fNum2 (+) (+))
(*) = Map.unionWith (fNum2 (*) (*))
fromInteger i = Map.singleton "n" $ VI (fromInteger i)
signum = (applyFIS signum signum id <$>)
abs = (applyFIS abs abs id <$>)
instance Fractional ValueMap where
recip = fmap (applyFIS recip id id)
fromRational r = Map.singleton "speed" $ VF (fromRational r)
class Moddable a where
gmod :: a -> a -> a
instance Moddable Double where
gmod = mod'
instance Moddable Rational where
gmod = mod'
instance Moddable Note where
gmod (Note a) (Note b) = Note (mod' a b)
instance Moddable Int where
gmod = mod
instance Moddable ValueMap where
gmod = Map.unionWith (fNum2 mod mod')
instance Floating ValueMap
where pi = noOv "pi"
exp _ = noOv "exp"
log _ = noOv "log"
sin _ = noOv "sin"
cos _ = noOv "cos"
asin _ = noOv "asin"
acos _ = noOv "acos"
atan _ = noOv "atan"
sinh _ = noOv "sinh"
cosh _ = noOv "cosh"
asinh _ = noOv "asinh"
acosh _ = noOv "acosh"
atanh _ = noOv "atanh"
------------------------------------------------------------------------
-- * Internal/fundamental functions
empty :: Pattern a
empty = Pattern {query = const []}
silence :: Pattern a
silence = empty
queryArc :: Pattern a -> Arc -> [Event a]
queryArc p a = query p $ State a Map.empty
-- | Splits queries that span cycles. For example `query p (0.5, 1.5)` would be
-- turned into two queries, `(0.5,1)` and `(1,1.5)`, and the results
-- combined. Being able to assume queries don't span cycles often
-- makes transformations easier to specify.
splitQueries :: Pattern a -> Pattern a
splitQueries p = p {query = \st -> concatMap (\a -> query p st {arc = a}) $ arcCyclesZW (arc st)}
-- | Apply a function to the arcs/timespans (both whole and parts) of the result
withResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a
withResultArc f pat = pat
{ query = map (\(Event c w p e) -> Event c (f <$> w) (f p) e) . query pat}
-- | Apply a function to the time (both start and end of the timespans
-- of both whole and parts) of the result
withResultTime :: (Time -> Time) -> Pattern a -> Pattern a
withResultTime f = withResultArc (\(Arc s e) -> Arc (f s) (f e))
-- | Apply a function to the timespan of the query
withQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a
withQueryArc f pat = pat {query = query pat . (\(State a m) -> State (f a) m)}
-- | Apply a function to the time (both start and end) of the query
withQueryTime :: (Time -> Time) -> Pattern a -> Pattern a
withQueryTime f pat = withQueryArc (\(Arc s e) -> Arc (f s) (f e)) pat
-- | Apply a function to the control values of the query
withQueryControls :: (ValueMap -> ValueMap) -> Pattern a -> Pattern a
withQueryControls f pat = pat { query = query pat . (\(State a m) -> State a (f m))}
-- | @withEvent f p@ returns a new @Pattern@ with each event mapped over
-- function @f@.
withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b
withEvent f p = p {query = map f . query p}
-- | @withEvent f p@ returns a new @Pattern@ with each value mapped over
-- function @f@.
withValue :: (a -> b) -> Pattern a -> Pattern b
withValue f pat = withEvent (fmap f) pat
-- | @withEvent f p@ returns a new @Pattern@ with f applied to the resulting list of events for each query
-- function @f@.
withEvents :: ([Event a] -> [Event b]) -> Pattern a -> Pattern b
withEvents f p = p {query = f . query p}
-- | @withPart f p@ returns a new @Pattern@ with function @f@ applied
-- to the part.
withPart :: (Arc -> Arc) -> Pattern a -> Pattern a
withPart f = withEvent (\(Event c w p v) -> Event c w (f p) v)
_extract :: (Value -> Maybe a) -> String -> ControlPattern -> Pattern a
_extract f name pat = filterJust $ withValue (Map.lookup name >=> f) pat
-- | Extract a pattern of integer values by from a control pattern, given the name of the control
extractI :: String -> ControlPattern -> Pattern Int
extractI = _extract getI
-- | Extract a pattern of floating point values by from a control pattern, given the name of the control
extractF :: String -> ControlPattern -> Pattern Double
extractF = _extract getF
-- | Extract a pattern of string values by from a control pattern, given the name of the control
extractS :: String -> ControlPattern -> Pattern String
extractS = _extract getS
-- | Extract a pattern of boolean values by from a control pattern, given the name of the control
extractB :: String -> ControlPattern -> Pattern Bool
extractB = _extract getB
-- | Extract a pattern of rational values by from a control pattern, given the name of the control
extractR :: String -> ControlPattern -> Pattern Rational
extractR = _extract getR
-- | Extract a pattern of note values by from a control pattern, given the name of the control
extractN :: String -> ControlPattern -> Pattern Note
extractN = _extract getN
compressArc :: Arc -> Pattern a -> Pattern a
compressArc (Arc s e) p | s > e = empty
| s > 1 || e > 1 = empty
| s < 0 || e < 0 = empty
| otherwise = s `rotR` _fastGap (1/(e-s)) p
compressArcTo :: Arc -> Pattern a -> Pattern a
compressArcTo (Arc s e) = compressArc (Arc (cyclePos s) (e - sam s))
focusArc :: Arc -> Pattern a -> Pattern a
focusArc (Arc s e) p = (cyclePos s) `rotR` (_fast (1/(e-s)) p)
{-| Speed up a pattern by the given time pattern.
For example, the following will play the sound pattern @"bd sn kurt"@ twice as
fast (i.e., so it repeats twice per cycle), and the vowel pattern three times
as fast:
> d1 $ sound (fast 2 "bd sn kurt")
> # fast 3 (vowel "a e o")
The first parameter can be patterned to, for example, play the pattern at twice
the speed for the first half of each cycle and then four times the speed for the
second half:
> d1 $ fast "2 4" $ sound "bd sn kurt cp"
-}
fast :: Pattern Time -> Pattern a -> Pattern a
fast = tParam _fast
{-| @fastSqueeze@ speeds up a pattern by a time pattern given as input,
squeezing the resulting pattern inside one cycle and playing the original
pattern at every repetition.
To better understand how it works, compare it with 'fast':
>>> print $ fast "1 2" $ s "bd sn"
(0>½)|s: "bd"
(½>¾)|s: "bd"
(¾>1)|s: "sn"
This will give @bd@ played in the first half cycle, and @bd sn@ in the second
half. On the other hand, using fastSqueeze;
>>> print $ fastSqueeze "1 2" $ s "bd sn"
(0>¼)|s: "bd"
(¼>½)|s: "sn"
(½>⅝)|s: "bd"
(⅝>¾)|s: "sn"
(¾>⅞)|s: "bd"
(⅞>1)|s: "sn"
The original pattern will play in the first half, and two repetitions of the
original pattern will play in the second half. That is, every repetition
contains the whole pattern.
If the time pattern has a single value, it becomes equivalent to 'fast':
> d1 $ fastSqueeze 2 $ s "bd sn"
> d1 $ fast 2 $ s "bd sn"
> d1 $ s "[bd sn]*2"
-}
fastSqueeze :: Pattern Time -> Pattern a -> Pattern a
fastSqueeze = tParamSqueeze _fast
-- | An alias for @fast@
density :: Pattern Time -> Pattern a -> Pattern a
density = fast
_fast :: Time -> Pattern a -> Pattern a
_fast rate pat | rate == 0 = silence
| rate < 0 = rev $ _fast (negate rate) pat
| otherwise = withResultTime (/ rate) $ withQueryTime (* rate) pat
{-| Slow down a pattern by the given time pattern.
For example, the following will play the sound pattern @"bd sn kurt"@ twice as
slow (i.e., so it repeats once every two cycles), and the vowel pattern three
times as slow:
> d1 $ sound (slow 2 "bd sn kurt")
> # slow 3 (vowel "a e o")
-}
slow :: Pattern Time -> Pattern a -> Pattern a
slow = tParam _slow
_slow :: Time -> Pattern a -> Pattern a
_slow 0 _ = silence
_slow r p = _fast (1/r) p
_fastGap :: Time -> Pattern a -> Pattern a
_fastGap 0 _ = empty
_fastGap r p = splitQueries $
withResultArc (\(Arc s e) -> Arc (sam s + ((s - sam s)/r'))
(sam s + ((e - sam s)/r'))
) $ p {query = f}
where r' = max r 1
-- zero width queries of the next sam should return zero in this case..
f st@(State a _) | start a' == nextSam (start a) = []
| otherwise = query p st {arc = a'}
where mungeQuery t = sam t + min 1 (r' * cyclePos t)
a' = (\(Arc s e) -> Arc (mungeQuery s) (mungeQuery e)) a
{-| Shifts a pattern back in time by the given amount, expressed in cycles.
This will skip to the fourth cycle:
> do
> resetCycles
> d1 $ rotL 4 $ seqP
> [ (0, 12, sound "bd bd*2")
> , (4, 12, sound "hh*2 [sn cp] cp future*4")
> , (8, 12, sound (samples "arpy*8" (run 16)))
> ]
Useful when building and testing out longer sequences.
-}
rotL :: Time -> Pattern a -> Pattern a
rotL t p = withResultTime (subtract t) $ withQueryTime (+ t) p
{-| Shifts a pattern forward in time by the given amount, expressed in cycles.
Opposite of 'rotL'.
-}
rotR :: Time -> Pattern a -> Pattern a
rotR t = rotL (negate t)
{- | @rev p@ returns @p@ with the event positions in each cycle reversed (or
mirrored).
For example rev @"1 [~ 2] ~ 3"@ is equivalent to rev @"3 ~ [2 ~] 1"@.
Note that @rev@ reverses on a cycle-by-cycle basis. This means that @rev (slow
2 "1 2 3 4")@ would actually result in @(slow 2 "2 1 4 3")@. This is because the
@slow 2@ makes the repeating pattern last two cycles, each of which is reversed
independently.
In practice rev is generally used with conditionals, for example with every:
> d1 $ every 3 rev $ n "0 1 [~ 2] 3" # sound "arpy"
or 'jux':
> d1 $ jux rev $ n (iter 4 "0 1 [~ 2] 3") # sound "arpy"
-}
rev :: Pattern a -> Pattern a
rev p =
splitQueries $ p {
query = \st -> map makeWholeAbsolute $
mapParts (mirrorArc (midCycle $ arc st)) $
map makeWholeRelative
(query p st
{arc = mirrorArc (midCycle $ arc st) (arc st)
})
}
where makeWholeRelative :: Event a -> Event a
makeWholeRelative e@Event {whole = Nothing} = e
makeWholeRelative (Event c (Just (Arc s e)) p'@(Arc s' e') v) =
Event c (Just $ Arc (s'-s) (e-e')) p' v
makeWholeAbsolute :: Event a -> Event a
makeWholeAbsolute e@Event {whole = Nothing} = e
makeWholeAbsolute (Event c (Just (Arc s e)) p'@(Arc s' e') v) =
Event c (Just $ Arc (s'-e) (e'+s)) p' v
midCycle :: Arc -> Time
midCycle (Arc s _) = sam s + 0.5
mapParts :: (Arc -> Arc) -> [Event a] -> [Event a]
mapParts f es = (\(Event c w p' v) -> Event c w (f p') v) <$> es
-- | Returns the `mirror image' of a 'Arc' around the given point in time
mirrorArc :: Time -> Arc -> Arc
mirrorArc mid' (Arc s e) = Arc (mid' - (e-mid')) (mid'+(mid'-s))
-- | Mark values in the first pattern which match with at least one
-- value in the second pattern.
matchManyToOne :: (b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b)
matchManyToOne f pa pb = pa {query = q}
where q st = map match $ query pb st
where
match ex@(Event xContext xWhole xPart x) =
Event (combineContexts $ xContext:map context as') xWhole xPart (any (f x . value) as', x)
where as' = as $ start $ wholeOrPart ex
as s = query pa $ fQuery s
fQuery s = st {arc = Arc s s}
-- ** Event filters
-- | Remove events from patterns that to not meet the given test
filterValues :: (a -> Bool) -> Pattern a -> Pattern a
filterValues f p = p {query = filter (f . value) . query p}
-- | Turns a pattern of 'Maybe' values into a pattern of values,
-- dropping the events of 'Nothing'.
filterJust :: Pattern (Maybe a) -> Pattern a
filterJust p = fromJust <$> filterValues isJust p
filterWhen :: (Time -> Bool) -> Pattern a -> Pattern a
filterWhen test p = p {query = filter (test . wholeStart) . query p}
filterOnsets :: Pattern a -> Pattern a
filterOnsets p = p {query = filter (\e -> eventPartStart e == wholeStart e) . query (filterDigital p)}
filterEvents :: (Event a -> Bool) -> Pattern a -> Pattern a
filterEvents f p = p {query = filter f . query p}
filterDigital :: Pattern a -> Pattern a
filterDigital = filterEvents isDigital
filterAnalog :: Pattern a -> Pattern a
filterAnalog = filterEvents isAnalog
playFor :: Time -> Time -> Pattern a -> Pattern a
playFor s e pat = Pattern $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ subArc (Arc s e) (arc st)
-- ** Temporal parameter helpers
tParam :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam f tv p = innerJoin $ (`f` p) <$> tv
tParam2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d
tParam2 f a b p = innerJoin $ (\x y -> f x y p) <$> a <*> b
tParam3 :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e)
tParam3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c
tParamSqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c)
tParamSqueeze f tv p = squeezeJoin $ (`f` p) <$> tv
-- ** Context
combineContexts :: [Context] -> Context
combineContexts = Context . concatMap contextPosition
setContext :: Context -> Pattern a -> Pattern a
setContext c pat = withEvents (map (\e -> e {context = c})) pat
withContext :: (Context -> Context) -> Pattern a -> Pattern a
withContext f pat = withEvents (map (\e -> e {context = f $ context e})) pat
-- A hack to add to manipulate source code to add calls to
-- 'deltaContext' around strings, so events from mininotation know
-- where they are within a whole tidal pattern
deltaMini :: String -> String
deltaMini = outside 0 0
where outside :: Int -> Int -> String -> String
outside _ _ [] = []
outside column line ('"':xs) = "(deltaContext "
++ show column
++ " "
++ show line
++ " \""
++ inside (column+1) line xs
outside _ line ('\n':xs) = '\n':outside 0 (line+1) xs
outside column line (x:xs) = x:outside (column+1) line xs
inside :: Int -> Int -> String -> String
inside _ _ [] = []
inside column line ('"':xs) = '"':')':outside (column+1) line xs
inside _ line ('\n':xs) = '\n':inside 0 (line+1) xs
inside column line (x:xs) = x:inside (column+1) line xs
class Stringy a where
deltaContext :: Int -> Int -> a -> a
instance Stringy (Pattern a) where
deltaContext column line pat = withEvents (map (\e -> e {context = f $ context e})) pat
where f :: Context -> Context
f (Context xs) = Context $ map (\((bx,by), (ex,ey)) -> ((bx+column,by+line), (ex+column,ey+line))) xs
-- deltaContext on an actual (non overloaded) string is a no-op
instance Stringy String where
deltaContext _ _ = id
-- ** Events
-- | Some context for an event, currently just position within sourcecode
data Context = Context {contextPosition :: [((Int, Int), (Int, Int))]}
deriving (Eq, Ord, Generic)
instance NFData Context
-- | An event is a value that's active during a timespan. If a whole
-- is present, the part should be equal to or fit inside it.
data EventF a b = Event
{ context :: Context
, whole :: Maybe a
, part :: a
, value :: b
} deriving (Eq, Ord, Functor, Generic)
instance (NFData a, NFData b) => NFData (EventF a b)
type Event a = EventF (ArcF Time) a
-- * Event utilities
isAnalog :: Event a -> Bool
isAnalog (Event {whole = Nothing}) = True
isAnalog _ = False
isDigital :: Event a -> Bool
isDigital = not . isAnalog
-- | `True` if an `Event`'s starts is within given `Arc`
onsetIn :: Arc -> Event a -> Bool
onsetIn a e = isIn a (wholeStart e)
-- | Returns a list of events, with any adjacent parts of the same whole combined
defragParts :: Eq a => [Event a] -> [Event a]
defragParts [] = []
defragParts [e] = [e]
defragParts (e:es) | isJust i = defraged : defragParts (delete e' es)
| otherwise = e : defragParts es
where i = findIndex (isAdjacent e) es
e' = es !! fromJust i
defraged = Event (context e) (whole e) u (value e)
u = hull (part e) (part e')
-- | Returns 'True' if the two given events are adjacent parts of the same whole
isAdjacent :: Eq a => Event a -> Event a -> Bool
isAdjacent e e' = (whole e == whole e')
&& (value e == value e')
&& ((stop (part e) == start (part e'))
||
(stop (part e') == start (part e))
)
wholeOrPart :: Event a -> Arc
wholeOrPart (Event {whole = Just a}) = a
wholeOrPart e = part e
-- | Get the onset of an event's 'whole'
wholeStart :: Event a -> Time
wholeStart = start . wholeOrPart
-- | Get the offset of an event's 'whole'
wholeStop :: Event a -> Time
wholeStop = stop . wholeOrPart
-- | Get the onset of an event's 'whole'
eventPartStart :: Event a -> Time
eventPartStart = start . part
-- | Get the offset of an event's 'part'
eventPartStop :: Event a -> Time
eventPartStop = stop . part
-- | Get the timespan of an event's 'part'
eventPart :: Event a -> Arc
eventPart = part
eventValue :: Event a -> a
eventValue = value
eventHasOnset :: Event a -> Bool
eventHasOnset e | isAnalog e = False
| otherwise = start (fromJust $ whole e) == start (part e)
-- TODO - Is this used anywhere? Just tests, it seems
-- TODO - support 'context' field
toEvent :: (((Time, Time), (Time, Time)), a) -> Event a
toEvent (((ws, we), (ps, pe)), v) = Event (Context []) (Just $ Arc ws we) (Arc ps pe) v
-- Resolves higher order VState values to plain values, by passing through (and changing) state
resolveState :: ValueMap -> [Event ValueMap] -> (ValueMap, [Event ValueMap])
resolveState sMap [] = (sMap, [])
resolveState sMap (e:es) = (sMap'', (e {value = v'}):es')
where f sm (VState v) = v sm
f sm v = (sm, v)
(sMap', v') | eventHasOnset e = Map.mapAccum f sMap (value e) -- pass state through VState functions
| otherwise = (sMap, Map.filter notVState $ value e) -- filter out VState values without onsets
(sMap'', es') = resolveState sMap' es
notVState (VState _) = False
notVState _ = True
-- ** Values
-- | Polymorphic values
data Value = VS { svalue :: String }
| VF { fvalue :: Double }
| VN { nvalue :: Note }
| VR { rvalue :: Rational }
| VI { ivalue :: Int }
| VB { bvalue :: Bool }
| VX { xvalue :: [Word8] } -- Used for OSC 'blobs'
| VPattern {pvalue :: Pattern Value}
| VList {lvalue :: [Value]}
| VState {statevalue :: ValueMap -> (ValueMap, Value)}
deriving (Typeable, Generic)
class Valuable a where
toValue :: a -> Value
instance NFData Value
type ValueMap = Map.Map String Value
-- | Note is Double, but with a different parser
newtype Note = Note { unNote :: Double }
deriving (Typeable, Data, Generic, Eq, Ord, Enum, Num, Fractional, Floating, Real, RealFrac)
instance NFData Note
instance Show Note where
show n = (show . unNote $ n) ++ "n (" ++ pitchClass ++ octave ++ ")"
where
pitchClass = pcs !! mod noteInt 12
octave = show $ div noteInt 12 + 5
noteInt = round . unNote $ n
pcs = ["c", "cs", "d", "ds", "e", "f", "fs", "g", "gs", "a", "as", "b"]
instance Valuable String where
toValue a = VS a
instance Valuable Double where
toValue a = VF a
instance Valuable Rational where
toValue a = VR a
instance Valuable Int where
toValue a = VI a
instance Valuable Bool where
toValue a = VB a
instance Valuable Note where
toValue a = VN a
instance Valuable [Word8] where
toValue a = VX a
instance Valuable [Value] where
toValue a = VList a
instance Eq Value where
(VS x) == (VS y) = x == y
(VB x) == (VB y) = x == y
(VF x) == (VF y) = x == y
(VI x) == (VI y) = x == y
(VN x) == (VN y) = x == y
(VR x) == (VR y) = x == y
(VX x) == (VX y) = x == y
(VF x) == (VI y) = x == fromIntegral y
(VI y) == (VF x) = x == fromIntegral y
(VF x) == (VR y) = toRational x == y
(VR y) == (VF x) = toRational x == y
(VI x) == (VR y) = toRational x == y
(VR y) == (VI x) = toRational x == y
_ == _ = False
instance Ord Value where
compare (VS x) (VS y) = compare x y
compare (VB x) (VB y) = compare x y
compare (VF x) (VF y) = compare x y
compare (VN x) (VN y) = compare (unNote x) (unNote y)
compare (VI x) (VI y) = compare x y
compare (VR x) (VR y) = compare x y
compare (VX x) (VX y) = compare x y
compare (VS _) _ = LT
compare _ (VS _) = GT
compare (VB _) _ = LT
compare _ (VB _) = GT
compare (VX _) _ = LT
compare _ (VX _) = GT
compare (VF x) (VI y) = compare x (fromIntegral y)
compare (VI x) (VF y) = compare (fromIntegral x) y
compare (VR x) (VI y) = compare x (fromIntegral y)
compare (VI x) (VR y) = compare (fromIntegral x) y
compare (VF x) (VR y) = compare x (fromRational y)
compare (VR x) (VF y) = compare (fromRational x) y
compare (VN x) (VI y) = compare x (fromIntegral y)
compare (VI x) (VN y) = compare (fromIntegral x) y
compare (VN x) (VR y) = compare (unNote x) (fromRational y)
compare (VR x) (VN y) = compare (fromRational x) (unNote y)
compare (VF x) (VN y) = compare x (unNote y)
compare (VN x) (VF y) = compare (unNote x) y
-- you can't really compare patterns, state or lists..
compare (VPattern _) (VPattern _) = EQ
compare (VPattern _) _ = GT
compare _ (VPattern _) = LT
compare (VState _) (VState _) = EQ
compare (VState _) _ = GT
compare _ (VState _) = LT
compare (VList _) (VList _) = EQ
compare (VList _) _ = GT
compare _ (VList _) = LT
-- | General utilities..
-- | Apply one of three functions to a Value, depending on its type
applyFIS :: (Double -> Double) -> (Int -> Int) -> (String -> String) -> Value -> Value
applyFIS f _ _ (VF f') = VF (f f')
applyFIS f _ _ (VN (Note f')) = VN (Note $ f f')
applyFIS _ f _ (VI i) = VI (f i)
applyFIS _ _ f (VS s) = VS (f s)
applyFIS f f' f'' (VState x) = VState $ \cmap -> (applyFIS f f' f'') <$> (x cmap)
applyFIS _ _ _ v = v
-- | Apply one of two functions to a pair of Values, depending on their types (int
-- or float; strings and rationals are ignored)
fNum2 :: (Int -> Int -> Int) -> (Double -> Double -> Double) -> Value -> Value -> Value
fNum2 fInt _ (VI a) (VI b) = VI (fInt a b)
fNum2 _ fFloat (VF a) (VF b) = VF (fFloat a b)
fNum2 _ fFloat (VN (Note a)) (VN (Note b)) = VN (Note $ fFloat a b)
fNum2 _ fFloat (VF a) (VN (Note b)) = VN (Note $ fFloat a b)
fNum2 _ fFloat (VN (Note a)) (VF b) = VN (Note $ fFloat a b)
fNum2 _ fFloat (VI a) (VF b) = VF (fFloat (fromIntegral a) b)
fNum2 _ fFloat (VF a) (VI b) = VF (fFloat a (fromIntegral b))
fNum2 fInt fFloat (VState a) b = VState $ \cmap -> ((\a' -> fNum2 fInt fFloat a' b) <$> (a cmap))
fNum2 fInt fFloat a (VState b) = VState $ \cmap -> ((\b' -> fNum2 fInt fFloat a b') <$> (b cmap))
fNum2 _ _ x _ = x
getI :: Value -> Maybe Int
getI (VI i) = Just i
getI (VR x) = Just $ floor x
getI (VF x) = Just $ floor x
getI _ = Nothing
getF :: Value -> Maybe Double
getF (VF f) = Just f
getF (VR x) = Just $ fromRational x
getF (VI x) = Just $ fromIntegral x
getF _ = Nothing
getN :: Value -> Maybe Note
getN (VN n) = Just n
getN (VF f) = Just $ Note f
getN (VR x) = Just $ Note $ fromRational x
getN (VI x) = Just $ Note $ fromIntegral x
getN _ = Nothing
getS :: Value -> Maybe String
getS (VS s) = Just s
getS _ = Nothing
getB :: Value -> Maybe Bool
getB (VB b) = Just b
getB _ = Nothing
getR :: Value -> Maybe Rational
getR (VR r) = Just r
getR (VF x) = Just $ toRational x
getR (VI x) = Just $ toRational x
getR _ = Nothing
getBlob :: Value -> Maybe [Word8]
getBlob (VX xs) = Just xs
getBlob _ = Nothing
getList :: Value -> Maybe [Value]
getList (VList vs) = Just vs
getList _ = Nothing
valueToPattern :: Value -> Pattern Value
valueToPattern (VPattern pat) = pat
valueToPattern v = pure v
--- functions relating to chords/patterns of lists
sameDur :: Event a -> Event a -> Bool
sameDur e1 e2 = (whole e1 == whole e2) && (part e1 == part e2)
groupEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [[Event a]]
groupEventsBy _ [] = []
groupEventsBy f (e:es) = eqs:(groupEventsBy f (es \\ eqs))
where eqs = e:[x | x <- es, f e x]
-- assumes that all events in the list have same whole/part
collectEvent :: [Event a] -> Maybe (Event [a])
collectEvent [] = Nothing
collectEvent l@(e:_) = Just $ e {context = con, value = vs}
where con = unionC $ map context l
vs = map value l
unionC [] = Context []
unionC ((Context is):cs) = Context (is ++ iss)
where Context iss = unionC cs
collectEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [Event [a]]
collectEventsBy f es = remNo $ map collectEvent (groupEventsBy f es)
where
remNo [] = []
remNo (Nothing:cs) = remNo cs
remNo ((Just c):cs) = c : (remNo cs)
-- | collects all events satisfying the same constraint into a list
collectBy :: Eq a => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a]
collectBy f = withEvents (collectEventsBy f)
-- | collects all events occuring at the exact same time into a list
collect :: Eq a => Pattern a -> Pattern [a]
collect = collectBy sameDur
uncollectEvent :: Event [a] -> [Event a]
uncollectEvent e = [e {value = (value e)!!i, context = resolveContext i (context e)} | i <-[0..length (value e) - 1]]
where resolveContext i (Context xs) = case length xs <= i of
True -> Context []
False -> Context [xs!!i]
uncollectEvents :: [Event [a]] -> [Event a]
uncollectEvents = concatMap uncollectEvent
-- | merges all values in a list into one pattern by stacking the values
uncollect :: Pattern [a] -> Pattern a
uncollect = withEvents uncollectEvents