tidal-core 1.9.6 → 1.10.0
raw patch · 23 files changed
+611/−777 lines, 23 filesdep +hspecdep −microspecdep ~containers
Dependencies added: hspec
Dependencies removed: microspec
Dependency ranges changed: containers
Files
- src/Sound/Tidal/Control.hs +5/−5
- src/Sound/Tidal/Core.hs +12/−15
- src/Sound/Tidal/Params.hs +12/−3
- src/Sound/Tidal/ParseBP.hs +55/−13
- src/Sound/Tidal/Pattern.hs +35/−42
- src/Sound/Tidal/Scales.hs +2/−2
- src/Sound/Tidal/Simple.hs +1/−1
- src/Sound/Tidal/Stepwise.hs +52/−58
- src/Sound/Tidal/UI.hs +49/−45
- test/Sound/Tidal/ChordsTest.hs +2/−2
- test/Sound/Tidal/ControlTest.hs +2/−2
- test/Sound/Tidal/CoreTest.hs +94/−105
- test/Sound/Tidal/ExceptionsTest.hs +2/−39
- test/Sound/Tidal/ParamsTest.hs +2/−2
- test/Sound/Tidal/ParseTest.hs +10/−10
- test/Sound/Tidal/PatternTest.hs +125/−163
- test/Sound/Tidal/ScalesTest.hs +2/−2
- test/Sound/Tidal/StepwiseTest.hs +18/−134
- test/Sound/Tidal/UITest.hs +67/−76
- test/Sound/Tidal/UtilsTest.hs +34/−35
- test/Test.hs +2/−2
- test/TestUtils.hs +25/−18
- tidal-core.cabal +3/−3
src/Sound/Tidal/Control.hs view
@@ -106,7 +106,7 @@ chopArc (Arc s e) n = map (\i -> Arc (s + (e - s) * (fromIntegral i / fromIntegral n)) (s + (e - s) * (fromIntegral (i + 1) / fromIntegral n))) [0 .. n - 1] _chop :: Int -> ControlPattern -> ControlPattern-_chop n pat = keepTactus (withTactus (* toRational n) pat) $ squeezeJoin $ f <$> pat+_chop n pat = keepSteps (withSteps (* toRational n) pat) $ squeezeJoin $ f <$> pat where f v = fastcat $ map (pure . rangemap v) slices rangemap v (b, e) = Map.union (fromMaybe (makeMap (b, e)) $ merge v (b, e)) v@@ -143,7 +143,7 @@ striate = patternify _striate _striate :: Int -> ControlPattern -> ControlPattern-_striate n p = keepTactus (withTactus (* toRational n) p) $ fastcat $ map offset [0 .. n - 1]+_striate n p = keepSteps (withSteps (* toRational n) p) $ fastcat $ map offset [0 .. n - 1] where offset i = mergePlayRange (fromIntegral i / fromIntegral n, fromIntegral (i + 1) / fromIntegral n) <$> p @@ -175,7 +175,7 @@ striate' = striateBy _striateBy :: Int -> Double -> ControlPattern -> ControlPattern-_striateBy n f p = keepTactus (withTactus (* toRational n) p) $ fastcat $ map (offset . fromIntegral) [0 .. n - 1]+_striateBy n f p = keepSteps (withSteps (* toRational n) p) $ fastcat $ map (offset . fromIntegral) [0 .. n - 1] where offset i = mergePlayRange (slot * i, (slot * i) + f) <$> p slot = (1 - f) / fromIntegral (n - 1)@@ -320,7 +320,7 @@ -- -- > d1 $ fast 4 $ randslice 32 $ sound "bev" randslice :: Pattern Int -> ControlPattern -> ControlPattern-randslice = patternify $ \n p -> keepTactus (withTactus (* (toRational n)) $ p) $ innerJoin $ (\i -> _slice n i p) <$> _irand n+randslice = patternify $ \n p -> keepSteps (withSteps (* (toRational n)) $ p) $ innerJoin $ (\i -> _slice n i p) <$> _irand n _splice :: Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value) _splice bits ipat pat = withEvent f (slice (pure bits) ipat pat) # P.unit (pure "c")@@ -338,7 +338,7 @@ -- -- > d1 $ splice 8 "[<0*8 0*2> 3*4 2 4] [4 .. 7]" $ sound "breaks165" splice :: Pattern Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value)-splice bitpat ipat pat = setTactusFrom bitpat $ innerJoin $ (\bits -> _splice bits ipat pat) <$> bitpat+splice bitpat ipat pat = setStepsFrom bitpat $ innerJoin $ (\bits -> _splice bits ipat pat) <$> bitpat -- | -- @loopAt@ makes a sample fit the given number of cycles. Internally, it
src/Sound/Tidal/Core.hs view
@@ -302,8 +302,8 @@ -- The first parameter to run can be given as a pattern: -- -- > d1 $ n (run "<4 8 4 6>") # sound "amencutup"-run :: (Enum a, Num a) => Pattern a -> Pattern a-run = (>>= _run)+run :: (Enum a, Num a, Real a) => Pattern a -> Pattern a+run npat = setSteps (toRational <$> pureValue npat) $ npat >>= _run _run :: (Enum a, Num a) => a -> Pattern a _run n = fastFromList [0 .. n - 1]@@ -377,12 +377,12 @@ -- > d1 $ fastcat [sound "bd*2 sn", sound "arpy jvbass*2", sound "drum*2"] -- > d1 $ fastcat [sound "bd*2 sn", sound "jvbass*3", sound "drum*2", sound "ht mt"] fastCat :: [Pattern a] -> Pattern a-fastCat (p : []) = p-fastCat ps = setTactus t $ _fast (toTime $ length ps) $ cat ps+fastCat [p] = p+fastCat ps = setSteps t $ _fast (toTime $ length ps) $ cat ps where- t = fastCat <$> (sequence $ map tactus ps)+ t = sum <$> mapM steps ps --- where t = fromMaybe (toRational $ length ps) $ ((* (toRational $ length ps)) . foldl1 lcmr) <$> (sequence $ map tactus ps)+-- where t = fromMaybe (toRational $ length ps) $ ((* (toRational $ length ps)) . foldl1 lcmr) <$> (sequence $ map steps ps) -- | Alias for @fastCat@ fastcat :: [Pattern a] -> Pattern a@@ -402,8 +402,8 @@ -- > , (1, s "superpiano" # n 0) -- > ] timeCat :: [(Time, Pattern a)] -> Pattern a-timeCat ((_, p) : []) = p-timeCat tps = setTactus (Just $ pure total) $ stack $ map (\(s, e, p) -> compressArc (Arc (s / total) (e / total)) p) $ arrange 0 $ filter (\(t, _) -> t > 0) $ tps+timeCat [(_, p)] = p+timeCat tps = setSteps (Just total) $ stack $ map (\(s, e, p) -> compressArc (Arc (s / total) (e / total)) p) $ arrange 0 $ filter (\(t, _) -> t > 0) $ tps where total = sum $ map fst tps arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)]@@ -468,14 +468,11 @@ -- > sound "arpy" +| n "0 .. 15" -- > ] # speed "[[1 0.8], [1.5 2]*2]/3" stack :: [Pattern a] -> Pattern a-stack pats = (foldr overlay silence pats) {tactus = t}+stack pats = (foldr overlay silence pats) {steps = t} where t- | length pats == 0 = Nothing- -- TODO - something cleverer..- | otherwise = (mono . stack) <$> (sequence $ map tactus pats)---- | otherwise = foldl1 lcmr <$> (sequence $ map tactus pats)+ | null pats = Nothing+ | otherwise = foldl1 lcmr <$> mapM steps pats -- ** Manipulating time @@ -538,7 +535,7 @@ zoomArc (Arc s e) p | s >= e = nothing | otherwise =- withTactus (* d) $+ withSteps (* d) $ splitQueries $ withResultArc (mapCycle ((/ d) . subtract s)) $ withQueryArc (mapCycle ((+ s) . (* d))) p
src/Sound/Tidal/Params.hs view
@@ -1,8 +1,7 @@ module Sound.Tidal.Params where --- Please note, this file is generated by bin/generate-params.hs--- Submit any pull requests against that file and/or params-header.hs--- in the same folder, thanks.+-- Please note, this file used to be generated by bin/generate-params.hs+-- We are currently updating it directly. {- Params.hs - Provides the basic control patterns available to TidalCycles by default@@ -352,6 +351,13 @@ bandqrecv :: Pattern Int -> ControlPattern bandqrecv busid = pI "^bandq" busid +-- | A pattern of strings. When sent to SuperDirt, will be prepended to sample+-- folder names, separated by an underscore. This allows sample sets to be+-- organised into separate banks. See+-- https://github.com/musikinformatik/SuperDirt/pull/312+bank :: Pattern String -> ControlPattern+bank = pS "bank"+ -- | @begin@ receives a pattern of numbers from 0 to 1 and skips the beginning -- of each sample by the indicated proportion. I.e., 0 would play the sample from -- the start, 1 would skip the whole sample, and 0.25 would cut off the first@@ -1708,6 +1714,9 @@ legatobus :: Pattern Int -> Pattern Double -> ControlPattern legatobus _ _ = error $ "Control parameter 'legato' can't be sent to a bus."++clip :: Pattern Double -> ControlPattern+clip = legato leslie :: Pattern Double -> ControlPattern leslie = pF "leslie"
src/Sound/Tidal/ParseBP.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-}@@ -31,28 +32,68 @@ import Control.Applicative () import qualified Control.Exception as E import Data.Bifunctor (first)-import Data.Colour-import Data.Colour.Names+import Data.Colour (Colour)+import Data.Colour.Names (readColourName) import Data.Functor (($>)) import Data.Functor.Identity (Identity) import Data.List (intercalate)-import Data.Maybe-import Data.Ratio+import Data.Maybe (fromMaybe)+import Data.Ratio ((%))+import Data.String (IsString (..)) import Data.Typeable (Typeable)-import GHC.Exts (IsString (..)) import Sound.Tidal.Chords+ ( Modifier (..),+ chordTable,+ chordToPatSeq,+ ) import Sound.Tidal.Core-import Sound.Tidal.Pattern hiding ((*>), (<*))+ ( cB_,+ cF_,+ cI_,+ cN_,+ cR_,+ cS_,+ fastFromList,+ stack,+ timeCat,+ _cX_,+ )+import Sound.Tidal.Pattern+ ( Context (Context),+ Note (Note),+ Pattern,+ Time,+ fast,+ getS,+ innerJoin,+ rotL,+ setContext,+ silence,+ slow,+ unwrap,+ ) import Sound.Tidal.UI+ ( chooseBy,+ euclidOff,+ euclidOffBool,+ rand,+ segment,+ _degradeByUsing,+ ) import Sound.Tidal.Utils (fromRight) import Text.Parsec.Error+ ( ParseError,+ errorMessages,+ errorPos,+ showErrorMessages,+ ) import qualified Text.Parsec.Prim import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Language (haskellDef) import qualified Text.ParserCombinators.Parsec.Token as P data TidalParseError = TidalParseError- { parsecError :: ParseError,+ { parsecError :: Text.Parsec.Error.ParseError, code :: String } deriving (Eq, Typeable)@@ -60,10 +101,11 @@ instance E.Exception TidalParseError instance Show TidalParseError where+ show :: TidalParseError -> String show err = "Syntax error in sequence:\n \"" ++ code err ++ "\"\n " ++ pointer ++ " " ++ message where- pointer = replicate (sourceColumn $ errorPos perr) ' ' ++ "^"- message = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" $ errorMessages perr+ pointer = replicate (sourceColumn $ Text.Parsec.Error.errorPos perr) ' ' ++ "^"+ message = Text.Parsec.Error.showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" $ Text.Parsec.Error.errorMessages perr perr = parsecError err type MyParser = Text.Parsec.Prim.Parsec String Int@@ -103,7 +145,7 @@ show (TPat_Repeat r v) = "TPat_Repeat (" ++ show r ++ ") (" ++ show v ++ ")" show (TPat_EnumFromTo a b) = "TPat_EnumFromTo (" ++ show a ++ ") (" ++ show b ++ ")" show (TPat_Var s) = "TPat_Var " ++ show s- show (TPat_Chord g iP nP msP) = "TPat_Chord (" ++ (show $ fmap g iP) ++ ") (" ++ show nP ++ ") (" ++ show msP ++ ")"+ show (TPat_Chord g iP nP msP) = "TPat_Chord (" ++ show (fmap g iP) ++ ") (" ++ show nP ++ ") (" ++ show msP ++ ")" instance Functor TPat where fmap f (TPat_Atom c v) = TPat_Atom c (f v)@@ -149,7 +191,7 @@ tShow TPat_Silence = "silence" tShow (TPat_EnumFromTo a b) = "unwrap $ fromTo <$> (" ++ tShow a ++ ") <*> (" ++ tShow b ++ ")" tShow (TPat_Var s) = "getControl " ++ s-tShow (TPat_Chord f n name mods) = "chord (" ++ (tShow $ fmap f n) ++ ") (" ++ tShow name ++ ")" ++ tShowList mods+tShow (TPat_Chord f n name mods) = "chord (" ++ tShow (fmap f n) ++ ") (" ++ tShow name ++ ")" ++ tShowList mods tShow a = "can't happen? " ++ show a toPat :: (Parseable a, Enumerable a) => TPat a -> Pattern a@@ -211,7 +253,7 @@ 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 (Pattern a)+parseBP :: (Enumerable a, Parseable a) => String -> Either Text.Parsec.Error.ParseError (Pattern a) parseBP s = toPat <$> parseTPat s parseBP_E :: (Enumerable a, Parseable a) => String -> Pattern a@@ -222,7 +264,7 @@ toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s} toE (Right tp) = toPat tp -parseTPat :: (Parseable a) => String -> Either ParseError (TPat a)+parseTPat :: (Parseable a) => String -> Either Text.Parsec.Error.ParseError (TPat a) parseTPat = runParser (pTidal parseRest <* eof) (0 :: Int) "" -- | a '-' is a negative sign if followed anything but another dash
src/Sound/Tidal/Pattern.hs view
@@ -56,7 +56,7 @@ } -- | A datatype representing events taking place over time-data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe (Pattern Rational), pureValue :: Maybe a}+data Pattern a = Pattern {query :: State -> [Event a], steps :: Maybe (Rational), pureValue :: Maybe a} deriving (Generic, Functor) instance (NFData a) => NFData (Pattern a)@@ -64,28 +64,25 @@ pattern :: (State -> [Event a]) -> Pattern a pattern f = Pattern f Nothing Nothing -setTactus :: Maybe (Pattern Rational) -> Pattern a -> Pattern a-setTactus r p = p {tactus = r}+setSteps :: Maybe Rational -> Pattern a -> Pattern a+setSteps r p = p {steps = r} -setTactusFrom :: Pattern b -> Pattern a -> Pattern a-setTactusFrom a b = b {tactus = tactus a}+setStepsFrom :: Pattern b -> Pattern a -> Pattern a+setStepsFrom a b = b {steps = steps a} -withTactus :: (Rational -> Rational) -> Pattern a -> Pattern a-withTactus f p = p {tactus = fmap (fmap f) $ tactus p}+withSteps :: (Rational -> Rational) -> Pattern a -> Pattern a+withSteps f p = p {steps = fmap f $ steps p} -steps :: Pattern Rational -> Pattern a -> Pattern a-steps target p@(Pattern _ (Just t) _) = setTactus (Just target) $ fast (target / t) p+pace :: Rational -> Pattern a -> Pattern a+pace target p@(Pattern _ (Just t) _) = setSteps (Just target) $ _fast (target / t) p -- raise error?-steps _ p = p---- _steps :: Pattern Rational -> Pattern a -> Pattern a--- _steps = patternify _steps+pace _ p = p keepMeta :: Pattern a -> Pattern a -> Pattern a-keepMeta from to = to {tactus = tactus from, pureValue = pureValue from}+keepMeta from to = to {steps = steps from, pureValue = pureValue from} -keepTactus :: Pattern a -> Pattern b -> Pattern b-keepTactus from to = to {tactus = tactus from}+keepSteps :: Pattern a -> Pattern b -> Pattern b+keepSteps from to = to {steps = steps from} -- type StateMap = Map.Map String (Pattern Value) type ControlPattern = Pattern ValueMap@@ -131,19 +128,19 @@ -- > (⅓>½)-⅔|11 -- > ⅓-(½>⅔)|12 -- > (⅔>1)|102- (<*>) a b = (applyPatToPatBoth a b) {tactus = (\a' b' -> lcmr <$> a' <*> b') <$> tactus a <*> tactus b}+ (<*>) a b = (applyPatToPatBoth a b) {steps = (\a' b' -> lcmr a' b') <$> steps a <*> steps b} -- | Like @<*>@, but the "wholes" come from the left (<*) :: Pattern (a -> b) -> Pattern a -> Pattern b-(<*) a b = keepTactus a $ applyPatToPatLeft a b+(<*) a b = keepSteps a $ applyPatToPatLeft a b -- | Like @<*>@, but the "wholes" come from the right (*>) :: Pattern (a -> b) -> Pattern a -> Pattern b-(*>) a b = keepTactus b $ applyPatToPatRight a b+(*>) a b = keepSteps b $ applyPatToPatRight a b -- | Like @<*>@, but the "wholes" come from the left (<<*) :: Pattern (a -> b) -> Pattern a -> Pattern b-(<<*) a b = (applyPatToPatSqueeze a b) {tactus = (*) <$> tactus a <*> tactus b}+(<<*) a b = (applyPatToPatSqueeze a b) {steps = (*) <$> steps a <*> steps b} infixl 4 <*, *>, <<* @@ -244,23 +241,19 @@ -- | 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 = setTactus (Just $ innerJoin' $ filterJust $ tactus <$> pp) $ innerJoin' pp+innerJoin :: Pattern (Pattern b) -> Pattern b+innerJoin pp' = pp' {query = q, pureValue = Nothing} where- -- \| innerJoin but without tactus manipulation (to avoid recursion)- innerJoin' :: Pattern (Pattern b) -> Pattern b- innerJoin' pp' = pp' {query = q, pureValue = Nothing}+ q st =+ concatMap+ (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op})+ (query pp' st) 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)+ 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.@@ -282,7 +275,7 @@ -- | 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?--- TODO - tactus+-- TODO - steps squeezeJoin :: Pattern (Pattern a) -> Pattern a squeezeJoin pp = pp {query = q, pureValue = Nothing} where@@ -567,13 +560,13 @@ -- * Internal/fundamental functions empty :: Pattern a-empty = Pattern {query = const [], tactus = Just 1, pureValue = Nothing}+empty = Pattern {query = const [], steps = Just 1, pureValue = Nothing} silence :: Pattern a silence = empty nothing :: Pattern a-nothing = empty {tactus = Just 0}+nothing = empty {steps = Just 0} queryArc :: Pattern a -> Arc -> [Event a] queryArc p a = query p $ State a Map.empty@@ -734,7 +727,7 @@ _fast rate pat | rate == 0 = silence | rate < 0 = rev $ _fast (negate rate) pat- | otherwise = keepTactus pat $ withResultTime (/ rate) $ withQueryTime (* rate) pat+ | otherwise = keepSteps pat $ withResultTime (/ rate) $ withQueryTime (* rate) pat -- | Slow down a pattern by the given time pattern. --@@ -902,9 +895,9 @@ patternify f (Pattern _ _ (Just a)) b = f a b patternify f pa p = innerJoin $ (`f` p) <$> pa --- versions that preserve the tactus+-- versions that preserve the steps patternify' :: (b -> Pattern c -> Pattern a) -> Pattern b -> Pattern c -> Pattern a-patternify' f pa p = (patternify f pa p) {tactus = tactus p}+patternify' f pa p = (patternify f pa p) {steps = steps p} patternify2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d patternify2 f (Pattern _ _ (Just a)) (Pattern _ _ (Just b)) c = f a b c@@ -918,7 +911,7 @@ patternify3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c patternify3' :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e)-patternify3' f a b c p = keepTactus p $ patternify3 f a b c p+patternify3' f a b c p = keepSteps p $ patternify3 f a b c p patternifySqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c) patternifySqueeze f tv p = squeezeJoin $ (`f` p) <$> tv
src/Sound/Tidal/Scales.hs view
@@ -308,7 +308,7 @@ noteInScale (fromMaybe [0] $ lookup scaleName table) n ) <$> p- <* sp+ <* sp where octave s x = x `div` length s noteInScale s x = (s !!! x) + fromIntegral (12 * octave s x)@@ -337,7 +337,7 @@ noteInScale (uniq $ f $ fromMaybe [0] $ lookup scaleName table) n ) <$> p- <* sp+ <* sp where octave s x = x `div` length s noteInScale s x = (s !!! x) + fromIntegral (12 * octave s x)
src/Sound/Tidal/Simple.hs view
@@ -21,7 +21,7 @@ module Sound.Tidal.Simple where -import GHC.Exts (IsString (..))+import Data.String (IsString (..)) import Sound.Tidal.Control (chop, hurry) import Sound.Tidal.Core ((#), (<~), (|*)) import Sound.Tidal.Params (crush, gain, pan, s, speed)
src/Sound/Tidal/Stepwise.hs view
@@ -1,5 +1,5 @@ {-- Tactus.hs - Functions that deal with stepwise manipulation of pattern+ Stepwise.hs - Functions that deal with stepwise manipulation of pattern Copyright (C) 2024, Alex McLean and contributors This library is free software: you can redistribute it and/or modify@@ -18,14 +18,14 @@ module Sound.Tidal.Stepwise where -import Data.List (sort, sortOn)-import Data.Maybe (fromJust, isJust, mapMaybe)-import Sound.Tidal.Core (stack, timecat, zoompat)+import Data.List (sort, sortOn, transpose)+import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe)+import Sound.Tidal.Core (stack, timecat, zoom, zoompat) import Sound.Tidal.Pattern import Sound.Tidal.Utils (enumerate, nubOrd, pairs) --- _lcmtactus :: [Pattern a] -> Maybe Time--- _lcmtactus pats = foldl1 lcmr <$> (sequence $ map tactus pats)+-- _lcmsteps :: [Pattern a] -> Maybe Time+-- _lcmsteps pats = foldl1 lcmr <$> (sequence $ map steps pats) s_patternify :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c) s_patternify f (Pattern _ _ (Just a)) b = f a b@@ -34,35 +34,21 @@ s_patternify2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d s_patternify2 f a b p = stepJoin $ (\x y -> f x y p) <$> a <*> b --- Breaks up pattern of patterns at event boundaries, then timecats them all together stepJoin :: Pattern (Pattern a) -> Pattern a-stepJoin pp = splitQueries $ Pattern q t Nothing+stepJoin pp = Pattern q first_t Nothing where- q st@(State a _) =- query- ( stepcat $- retime $- slices $- query (rotL (sam $ start a) pp) (st {arc = Arc 0 1})- )- st- -- TODO what's the tactus of the tactus and does it matter?- t :: Maybe (Pattern Rational)- t = Just $ Pattern t_q Nothing Nothing- t_q :: State -> [Event Rational]- t_q st@(State a' _) = maybe [] (`query` st) (tactus (stepcat $ retime $ slices $ query (rotL (sam $ start a') pp) (st {arc = Arc 0 1})))- -- retime each pattern slice- retime :: [(Time, Pattern a)] -> [Pattern a]+ q st@(State a c) = query (timecat $ retime $ slices $ query (rotL (sam $ start a) pp) (st {arc = Arc 0 1})) st+ first_t :: Maybe Rational+ first_t = steps $ timecat $ retime $ slices $ queryArc pp (Arc 0 1)+ retime :: [(Time, Pattern a)] -> [(Time, Pattern a)] retime xs = map (uncurry adjust) xs where- occupied_perc = sum $ map fst $ filter (isJust . tactus . snd) xs- occupied_tactus = sum $ mapMaybe (tactus . snd) xs- total_tactus = (/ occupied_perc) <$> occupied_tactus- adjust _ pat@(Pattern {tactus = Just _}) = pat- adjust dur pat = setTactus (Just $ (* dur) <$> total_tactus) pat- -- break up events at all start/end points, into groups- -- stacked into single patterns, with duration. Some patterns- -- will be have no events.+ occupied_perc = sum $ map fst $ filter (isJust . steps . snd) xs+ occupied_tactus = sum $ mapMaybe (steps . snd) xs+ total_tactus = occupied_tactus / occupied_perc+ adjust _ pat@(Pattern {steps = Just t}) = (t, pat)+ adjust dur pat = (dur * total_tactus, pat)+ -- break up events at all start/end points, into groups, including empty ones. slices :: [Event (Pattern a)] -> [(Time, Pattern a)] slices evs = map (\s -> (snd s - fst s, stack $ map (\x -> withContext (\c -> combineContexts [c, context x]) $ value x) $ fit s evs)) $ pairs $ sort $ nubOrd $ 0 : 1 : concatMap (\ev -> start (part ev) : stop (part ev) : []) evs -- list of slices of events within the given range@@ -74,44 +60,47 @@ a <- subArc (Arc b e) $ part ev return ev {part = a} +-- stepcat :: [Pattern a] -> Pattern a+-- stepcat pats = innerJoin $ timecat . map snd . sortOn fst <$> tpat (epats pats)+-- where+-- -- enumerated patterns, ignoring those without steps+-- epats :: [Pattern a] -> [(Int, Pattern a)]+-- epats = enumerate . filter (isJust . steps)+-- --+-- tpat :: [(Int, Pattern a)] -> Pattern [(Int, (Time, Pattern a))]+-- tpat = mapM (\(i, pat) -> (\t -> (i, (t, pat))) <$> fromJust (steps pat))+ stepcat :: [Pattern a] -> Pattern a-stepcat pats = innerJoin $ (timecat . map snd . sortOn fst) <$> (tpat $ epats pats)- where- -- enumerated patterns, ignoring those without tactus- epats :: [Pattern a] -> [(Int, Pattern a)]- epats = enumerate . filter (isJust . tactus)- --- tpat :: [(Int, Pattern a)] -> Pattern [(Int, (Time, Pattern a))]- tpat = mapM (\(i, pat) -> (\t -> (i, (t, pat))) <$> fromJust (tactus pat))+stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ steps pat, pat)) pats -_steptake :: Time -> Pattern a -> Pattern a+_take :: Time -> Pattern a -> Pattern a -- raise error?-_steptake _ pat@(Pattern _ Nothing _) = pat-_steptake n pat@(Pattern _ (Just tpat) _) = setTactus (Just tpat') $ zoompat b e pat+_take _ pat@(Pattern _ Nothing _) = pat+_take n pat@(Pattern _ (Just t) _) = setSteps (Just t') $ zoom (b, e) pat where- b = (\t -> if n >= 0 then 0 else 1 - ((abs n) / t)) <$> tpat- e = (\t -> if n >= 0 then n / t else 1) <$> tpat- tpat' = (\t -> min (abs n) t) <$> tpat+ b = if n >= 0 then 0 else 1 - (abs n / t)+ e = if n >= 0 then n / t else 1+ t' = min (abs n) t steptake :: Pattern Time -> Pattern a -> Pattern a-steptake = s_patternify _steptake+steptake = s_patternify _take _stepdrop :: Time -> Pattern a -> Pattern a _stepdrop _ pat@(Pattern _ Nothing _) = pat-_stepdrop n pat@(Pattern _ (Just tpat) _) = steptake (f <$> tpat) pat+_stepdrop n pat@(Pattern _ (Just t) _) = steptake (pure $ f t) pat where f t | n >= 0 = t - n- | otherwise = 0 - (t + n)+ | otherwise = negate (t + n) stepdrop :: Pattern Time -> Pattern a -> Pattern a stepdrop = s_patternify _stepdrop _expand :: Rational -> Pattern a -> Pattern a-_expand factor pat = withTactus (* factor) pat+_expand factor pat = withSteps (* factor) pat _contract :: Rational -> Pattern a -> Pattern a-_contract factor pat = withTactus (/ factor) pat+_contract factor pat = withSteps (/ factor) pat expand :: Pattern Rational -> Pattern a -> Pattern a expand = s_patternify _expand@@ -119,6 +108,18 @@ contract :: Pattern Rational -> Pattern a -> Pattern a contract = s_patternify _contract +_extend :: Rational -> Pattern a -> Pattern a+_extend factor pat = _expand factor $ _fast factor pat++extend :: Pattern Rational -> Pattern a -> Pattern a+extend = s_patternify _extend++-- | Successively plays a pattern from each group in turn+stepalt :: [[Pattern a]] -> Pattern a+stepalt groups = stepcat $ concat $ take (fromIntegral $ c * length groups) $ transpose $ map cycle groups+ where+ c = foldl1 lcm $ map length groups+ {- s_while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a s_while patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat@@ -131,7 +132,7 @@ | otherwise = applyWhen stepwise (_fast t) $ s_cat $ applyWhen lastone reverse $ (f $ head cycles) : tail cycles where cycles = applyWhen lastone reverse $ separateCycles n $ applyWhen stepwise (_slow t) pat- t = fromMaybe 1 $ tactus pat+ t = fromMaybe 1 $ steps pat s_nthcycle :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a s_nthcycle (Pattern _ _ (Just i)) f pat = _s_nth True False i f pat@@ -186,11 +187,4 @@ -- | Plays one fewer step from the pattern each repetition, down to nothing s_taperBy :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a s_taperBy = s_patternify2 _s_taperBy---- | Successively plays a pattern from each group in turn-s_alt :: [[Pattern a]] -> Pattern a-s_alt groups = s_cat $ concat $ take (c * length groups) $ transpose $ map cycle groups- where- c = foldl1 lcm $ map length groups- -}
src/Sound/Tidal/UI.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-} {- UI.hs - Tidal's main 'user interface' functions, for transforming@@ -36,9 +35,9 @@ import Data.Bool (bool) import Data.Char (digitToInt, isDigit, ord) import Data.Fixed (mod')+import qualified Data.IntMap.Strict as IM import Data.List ( elemIndex,- findIndex, findIndices, groupBy, intercalate,@@ -46,10 +45,10 @@ sortOn, transpose, )+import qualified Data.List as L import qualified Data.Map.Strict as Map import Data.Maybe- ( catMaybes,- fromJust,+ ( fromJust, fromMaybe, isJust, mapMaybe,@@ -97,7 +96,9 @@ intSeedToRand = (/ 536870912) . realToFrac . (`mod` 536870912) timeToRand :: (RealFrac a, Fractional b) => a -> b-timeToRand = intSeedToRand . timeToIntSeed+-- Otherwise the value would be 0 at time 0.. Let's start in the middle.+timeToRand 0 = 0.5+timeToRand t = intSeedToRand $ timeToIntSeed t timeToRands :: (RealFrac a, Fractional b) => a -> Int -> [b] timeToRands 0 n = timeToRands' (timeToIntSeed (9999999 :: Double)) n@@ -139,7 +140,7 @@ -- -- > jux (# ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand rand :: (Fractional a) => Pattern a-rand = pattern (\(State a@(Arc s e) _) -> [Event (Context []) Nothing a (realToFrac $ (timeToRand ((e + s) / 2) :: Double))])+rand = pattern (\(State a@(Arc s _) _) -> [Event (Context []) Nothing a (realToFrac (timeToRand s :: Double))]) -- | Boolean rand - a continuous stream of true\/false values, with a 50\/50 chance. brand :: Pattern Bool@@ -175,7 +176,7 @@ -- -- The `perlin` function uses the cycle count as input and can be used much like @rand@. perlinWith :: (Fractional a) => Pattern Double -> Pattern a-perlinWith p = fmap realToFrac $ (interp) <$> (p - pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb)+perlinWith p = fmap realToFrac $ interp <$> (p - pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb) where pa = (fromIntegral :: Int -> Double) . floor <$> p pb = (fromIntegral :: Int -> Double) . (+ 1) . floor <$> p@@ -293,19 +294,19 @@ -- play as the "e" note, and half as likely to play as the "g" note. -- -- > wchoose = 'wchooseBy' 'rand'-wchoose :: [(a, Double)] -> Pattern a+wchoose :: [(a, Pattern Double)] -> Pattern a wchoose = wchooseBy rand -- | Given a pattern of probabilities and a list of @(value, weight)@ pairs, -- @wchooseBy@ creates a @'Pattern' value@ by choosing values based on those -- probabilities and weighted appropriately by the weights in the list of pairs.-wchooseBy :: Pattern Double -> [(a, Double)] -> Pattern a-wchooseBy pat pairs = match <$> pat+wchooseBy :: Pattern Double -> [(a, Pattern Double)] -> Pattern a+wchooseBy pat pairs = match <$> pat <* cweightpat <* totalpat where- match r = values !! head (findIndices (> (r * total)) cweights)- cweights = scanl1 (+) (map snd pairs)+ match r cweights total = values !! head (findIndices (> (r * total)) cweights)+ cweightpat = sequence $ scanl1 (+) (map snd pairs) values = map fst pairs- total = sum $ map snd pairs+ totalpat = sum $ map snd pairs -- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but -- randomises the order in which they are played.@@ -321,7 +322,7 @@ -- > d1 $ sound -- > $ wrandcat -- > [ ("bd*2 sn", 5), ("jvbass*3", 2), ("drum*2", 2), ("ht mt", 1) ]-wrandcat :: [(Pattern a, Double)] -> Pattern a+wrandcat :: [(Pattern a, Pattern Double)] -> Pattern a wrandcat ps = unwrap $ wchooseBy (segment 1 rand) ps -- | @degrade@ randomly removes events from a pattern 50% of the time:@@ -365,7 +366,7 @@ -- Useful for manipulating random stream, e.g. to change 'seed' _degradeByUsing :: Pattern Double -> Double -> Pattern a -> Pattern a-_degradeByUsing prand x p = fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <* prand+_degradeByUsing prand x p = fmap fst $ filterValues ((>= x) . snd) $ (,) <$> p <* prand -- | -- As 'degradeBy', but the pattern of probabilities represents the chances to retain rather@@ -374,7 +375,7 @@ unDegradeBy = patternify' _unDegradeBy _unDegradeBy :: Double -> Pattern a -> Pattern a-_unDegradeBy x p = fmap fst $ filterValues ((<= x) . snd) $ (,) <$> p <* rand+_unDegradeBy x p = fmap fst $ filterValues ((< x) . snd) $ (,) <$> p <* rand degradeOverBy :: Int -> Pattern Double -> Pattern a -> Pattern a degradeOverBy i tx p = unwrap $ (\x -> fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <* fastRepeatCycles i rand) <$> slow (fromIntegral i) tx@@ -455,10 +456,8 @@ -- | -- Never apply a transformation, returning the pattern unmodified.------ @never = flip const@ never :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-never = flip const+never _ x = x -- | -- Apply the transformation to the pattern unconditionally.@@ -536,7 +535,7 @@ -- -- There is also `iter'`, which shifts the pattern in the opposite direction. iter :: Pattern Int -> Pattern c -> Pattern c-iter a pat = keepTactus pat $ patternify' _iter a pat+iter a pat = keepSteps pat $ patternify' _iter a pat _iter :: Int -> Pattern a -> Pattern a _iter n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotL` p) [0 .. (n - 1)]@@ -720,7 +719,7 @@ whenmod a b f pat = innerJoin $ (\a' b' -> _whenmod a' b' f pat) <$> a <*> b _whenmod :: Time -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_whenmod a b = whenT (\t -> ((t `mod'` a) >= b))+_whenmod a b = whenT (\t -> (t `mod'` a) >= b) -- | -- > superimpose f p = stack [p, f p]@@ -927,8 +926,8 @@ _euclid :: Int -> Int -> Pattern a -> Pattern a _euclid n k a- | n >= 0 = fastcat $ fmap (bool silence a) $ bjorklund (n, k)- | otherwise = fastcat $ fmap (bool a silence) $ bjorklund (-n, k)+ | n >= 0 = setSteps (Just $ toRational k) $ fastcat $ fmap (bool silence a) $ bjorklund (n, k)+ | otherwise = setSteps (Just $ toRational k) $ fastcat $ fmap (bool a silence) $ bjorklund (-n, k) -- | --@@ -941,16 +940,16 @@ -- -- > d1 $ euclidFull 3 7 "realclaps" ("realclaps" # gain 0.8) euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a-euclidFull n k pa pb = stack [euclid n k pa, euclidInv n k pb]+euclidFull n k pa pb = setSteps (toRational <$> pureValue k) $ stack [euclid n k pa, euclidInv n k pb] -- | Less expressive than 'euclid' due to its constrained types, but may be more efficient. _euclidBool :: Int -> Int -> Pattern Bool -- TODO: add 'euclidBool'? _euclidBool n k- | n >= 0 = fastFromList $ bjorklund (n, k)- | otherwise = fastFromList $ fmap (not) $ bjorklund (-n, k)+ | n >= 0 = setSteps (Just $ toRational k) $ fastFromList $ bjorklund (n, k)+ | otherwise = setSteps (Just $ toRational k) $ fastFromList $ fmap not $ bjorklund (-n, k) _euclid' :: Int -> Int -> Pattern a -> Pattern a-_euclid' n k p = fastcat $ map (\x -> if x then p else silence) (bjorklund (n, k))+_euclid' n k p = setSteps (Just $ toRational k) $ fastcat $ map (\x -> if x then p else silence) (bjorklund (n, k)) -- | -- As 'euclid', but taking a third rotational parameter corresponding to the onset@@ -964,7 +963,7 @@ _euclidOff :: Int -> Int -> Int -> Pattern a -> Pattern a _euclidOff _ 0 _ _ = silence-_euclidOff n k s p = (rotL $ fromIntegral s % fromIntegral k) (_euclid n k p)+_euclidOff n k s p = setSteps (Just $ toRational k) $ (rotL $ fromIntegral s % fromIntegral k) (_euclid n k p) -- | As 'euclidOff', but specialized to 'Bool'. May be more efficient than 'euclidOff'. euclidOffBool :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern Bool -> Pattern Bool@@ -972,7 +971,7 @@ _euclidOffBool :: Int -> Int -> Int -> Pattern Bool -> Pattern Bool _euclidOffBool _ 0 _ _ = silence-_euclidOffBool n k s p = ((fromIntegral s % fromIntegral k) `rotL`) ((\a b -> if b then a else not a) <$> _euclidBool n k <*> p)+_euclidOffBool n k s p = setSteps (Just $ toRational k) $ rotL (fromIntegral s % fromIntegral k) ((\a b -> if b then a else not a) <$> _euclidBool n k <*> p) distrib :: [Pattern Int] -> Pattern a -> Pattern a distrib ps p = do@@ -1185,7 +1184,7 @@ segment = patternify _segment _segment :: Time -> Pattern a -> Pattern a-_segment n p = setTactus (Just $ pure n) $ _fast n (pure id) <* p+_segment n p = setSteps (Just $ n) $ _fast n (pure id) <* p -- | @discretise@: the old (deprecated) name for 'segment' discretise :: Pattern Time -> Pattern a -> Pattern a@@ -1237,7 +1236,7 @@ -- @"arpy:1"@, @"casio"@ and @"bd"@, giving the pattern -- @"arpy:1 [~ casio] bd casio"@ (note that the list wraps round here). fit :: Pattern Int -> [a] -> Pattern Int -> Pattern a-fit pint xs p = (patternify func) pint (xs, p)+fit pint xs p = patternify func pint (xs, p) where func i (xs', p') = _fit i xs' p' @@ -1247,7 +1246,7 @@ pos e = perCycle * floor (start $ part e) permstep :: (RealFrac b) => Int -> [a] -> Pattern b -> Pattern a-permstep nSteps things p = unwrap $ (\n -> fastFromList $ concatMap (\x -> replicate (fst x) (snd x)) $ zip (ps !! floor (n * fromIntegral (length ps - 1))) things) <$> _segment 1 p+permstep nSteps things p = unwrap $ (\n -> fastFromList $ concatMap (uncurry replicate) $ zip (ps !! floor (n * fromIntegral (length ps - 1))) things) <$> _segment 1 p where ps = permsort (length things) nSteps deviance avg xs = sum $ map (abs . (avg -) . fromIntegral) xs@@ -1429,12 +1428,16 @@ -- transition probability from state 0->0 is 2/5, 0->1 is 3/5, 1->0 is 1/4, and -- 1->1 is 3/4. runMarkov :: Int -> [[Double]] -> Int -> Time -> [Int]-runMarkov n tp xi seed = reverse $ (iterate (markovStep $ renorm) [xi]) !! (n - 1)+runMarkov n tp xi seed = take n $ map fst $ L.iterate' (markovStep $ renorm) (xi, seed + delta) where- markovStep tp' xs = (fromJust $ findIndex (r <=) $ scanl1 (+) (tp' !! (head xs))) : xs+ markovStep tp' (x, seed') = (let v = tp' IM.! x in findIndex (r * fst (Map.findMax v)) v, seed' + delta) where- r = timeToRand $ seed + (fromIntegral . length) xs / fromIntegral n- renorm = [map (/ sum x) x | x <- tp]+ r = timeToRand seed'+ renorm :: IM.IntMap (Map.Map Double Int)+ renorm = IM.fromList $ zip [0 ..] [Map.fromList $ zip (tail $ scanl (+) 0 x) [0 ..] | x <- tp]+ findIndex :: Double -> Map.Map Double Int -> Int+ findIndex x v = maybe 0 snd (Map.lookupGE x v)+ delta = 1 / fromIntegral n -- | @markovPat n xi tp@ generates a one-cycle pattern of @n@ steps in a Markov -- chain starting from state @xi@ with transition matrix @tp@. Each row of the@@ -1454,7 +1457,7 @@ _markovPat :: Int -> Int -> [[Double]] -> Pattern Int _markovPat n xi tp =- setTactus (Just $ pure $ toRational n) $+ setSteps (Just $ toRational n) $ splitQueries $ pattern ( \(State a@(Arc s _) _) ->@@ -2220,8 +2223,9 @@ sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a -- Replaced with more efficient version below -- sew pb a b = overlay (mask pb a) (mask (inv pb) b)-sew pb a b = Pattern pf Nothing Nothing+sew pb a b = Pattern pf psteps Nothing where+ psteps = pureValue pb >>= \v -> if v then steps a else steps b pf st = concatMap match evs where evs = query pb st@@ -2230,7 +2234,7 @@ match ev | value ev = find (query a st {arc = subarc}) ev | otherwise = find (query b st {arc = subarc}) ev- find evs' ev = catMaybes $ map (check ev) evs'+ find evs' ev = mapMaybe (check ev) evs' check bev xev = do newarc <- subArc (part bev) (part xev) return $ xev {part = newarc}@@ -2251,7 +2255,7 @@ -- value is active. No events are let through where no binary values -- are active. while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-while b f pat = keepTactus pat $ sew b (f pat) pat+while b f pat = sew b (f pat) pat -- | -- @stutter n t pat@ repeats each event in @pat@ @n@ times, separated by @t@ time (in fractions of a cycle).@@ -2348,8 +2352,8 @@ (Pattern ValueMap -> Pattern ValueMap) -> Pattern ValueMap -> Pattern ValueMap--- TODO: lcm tactus of p and f p?-juxBy n f p = keepTactus p $ stack [p |+ P.pan 0.5 |- P.pan (n / 2), f $ p |+ P.pan 0.5 |+ P.pan (n / 2)]+-- TODO: lcm steps of p and f p?+juxBy n f p = keepSteps p $ stack [p |+ P.pan 0.5 |- P.pan (n / 2), f $ p |+ P.pan 0.5 |+ P.pan (n / 2)] -- | -- Given a sample's directory name and number, this generates a string@@ -2428,7 +2432,7 @@ -- > d1 $ jux (iter 4) $ sound "arpy arpy:2*2" -- > |+ speed (slow 4 $ sine1 * 0.5 + 1) range :: (Num a) => Pattern a -> Pattern a -> Pattern a -> Pattern a-range fromP toP p = (\from to v -> ((v * (to - from)) + from)) <$> fromP *> toP *> p+range fromP toP p = (\from to v -> (v * (to - from)) + from) <$> fromP *> toP *> p _range :: (Functor f, Num b) => b -> b -> f b -> f b _range from to p = (+ from) . (* (to - from)) <$> p@@ -2891,7 +2895,7 @@ _chew :: Int -> Pattern Int -> ControlPattern -> ControlPattern _chew n ipat pat = squeezeJoinUp (zoomslice <$> ipat) |/ P.speed (pure $ fromIntegral n) where- zoomslice i = zoom (i' / (fromIntegral n), (i' + 1) / (fromIntegral n)) (pat)+ zoomslice i = zoom (i' / fromIntegral n, (i' + 1) / fromIntegral n) pat where i' = fromIntegral $ i `mod` n @@ -2913,7 +2917,7 @@ _binary n num = listToPat $ __binary n num _binaryN :: Int -> Pattern Int -> Pattern Bool-_binaryN n p = setTactus (Just $ pure $ toRational n) $ squeezeJoin $ _binary n <$> p+_binaryN n p = setSteps (Just $ toRational n) $ squeezeJoin $ _binary n <$> p binaryN :: Pattern Int -> Pattern Int -> Pattern Bool binaryN n p = patternify _binaryN n p
test/Sound/Tidal/ChordsTest.hs view
@@ -3,11 +3,11 @@ module Sound.Tidal.ChordsTest where import Sound.Tidal.Pattern-import Test.Microspec+import Test.Hspec import TestUtils import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Chords" $ do describe "chord" $ do
test/Sound/Tidal/ControlTest.hs view
@@ -6,11 +6,11 @@ import Sound.Tidal.Core import Sound.Tidal.Params import Sound.Tidal.Pattern-import Test.Microspec+import Test.Hspec import TestUtils import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Control" $ do describe "echo" $ do
test/Sound/Tidal/CoreTest.hs view
@@ -5,21 +5,15 @@ import Data.List (sort) import qualified Data.Map as Map import Data.Ratio-import Sound.Tidal.Control as C import Sound.Tidal.Core as C-import Sound.Tidal.Params as C-import Sound.Tidal.ParseBP as C import Sound.Tidal.Pattern as C-import Sound.Tidal.Scales as C-import Sound.Tidal.Show as C-import Sound.Tidal.Simple as C-import Sound.Tidal.Stepwise as C import Sound.Tidal.UI as C-import Test.Microspec+import Test.Hspec+import Test.Hspec.QuickCheck import TestUtils import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Core" $ do describe "Elemental patterns" $ do@@ -29,23 +23,23 @@ let inNormalRange pat t = (y >= 0) && (y <= 1) where y = sampleOf pat t- it "sine" $ inNormalRange sine- it "cosine" $ inNormalRange cosine- it "saw" $ inNormalRange saw- it "isaw" $ inNormalRange isaw- it "tri" $ inNormalRange tri- it "square" $ inNormalRange square+ prop "sine" $ inNormalRange sine+ prop "cosine" $ inNormalRange cosine+ prop "saw" $ inNormalRange saw+ prop "isaw" $ inNormalRange isaw+ prop "tri" $ inNormalRange tri+ prop "square" $ inNormalRange square describe "have correctly-scaled bipolar variants" $ do let areCorrectlyScaled pat pat2 t = (y * 2 - 1) ~== y2 where y = sampleOf pat t y2 = sampleOf pat2 t- it "sine" $ areCorrectlyScaled sine sine2- it "cosine" $ areCorrectlyScaled cosine cosine2- it "saw" $ areCorrectlyScaled saw saw2- it "isaw" $ areCorrectlyScaled isaw isaw2- it "tri" $ areCorrectlyScaled tri tri2- it "square" $ areCorrectlyScaled square square2+ prop "sine" $ areCorrectlyScaled sine sine2+ prop "cosine" $ areCorrectlyScaled cosine cosine2+ prop "saw" $ areCorrectlyScaled saw saw2+ prop "isaw" $ areCorrectlyScaled isaw isaw2+ prop "tri" $ areCorrectlyScaled tri tri2+ prop "square" $ areCorrectlyScaled square square2 describe "append" $ it "can switch between the cycles from two pures" $ do@@ -80,30 +74,28 @@ (cat [rev a, rev b, rev c]) describe "fastCat" $ do- it "can switch between the cycles from three pures inside one cycle" $ do- it "1" $- queryArc (fastCat [pure "a", pure "b", pure "c"]) (Arc 0 1)- `shouldBe` fmap- toEvent- [ (((0, 1 / 3), (0, 1 / 3)), "a" :: String),- (((1 / 3, 2 / 3), (1 / 3, 2 / 3)), "b"),- (((2 / 3, 1), (2 / 3, 1)), "c")- ]- it "5/3" $- queryArc (fastCat [pure "a", pure "b", pure "c"]) (Arc 0 (5 / 3))- `shouldBe` fmap- toEvent- [ (((0, 1 / 3), (0, 1 / 3)), "a" :: String),- (((1 / 3, 2 / 3), (1 / 3, 2 / 3)), "b"),- (((2 / 3, 1), (2 / 3, 1)), "c"),- (((1, 4 / 3), (1, 4 / 3)), "a"),- (((4 / 3, 5 / 3), (4 / 3, 5 / 3)), "b")- ]- it "works with zero-length queries" $ do- it "0" $+ it "can switch between the cycles from three pures inside one cycle (1)" $ do+ queryArc (fastCat [pure "a", pure "b", pure "c"]) (Arc 0 1)+ `shouldBe` fmap+ toEvent+ [ (((0, 1 / 3), (0, 1 / 3)), "a" :: String),+ (((1 / 3, 2 / 3), (1 / 3, 2 / 3)), "b"),+ (((2 / 3, 1), (2 / 3, 1)), "c")+ ]+ it "can switch between the cycles from three pures inside one cycle (5/3)" $ do+ queryArc (fastCat [pure "a", pure "b", pure "c"]) (Arc 0 (5 / 3))+ `shouldBe` fmap+ toEvent+ [ (((0, 1 / 3), (0, 1 / 3)), "a" :: String),+ (((1 / 3, 2 / 3), (1 / 3, 2 / 3)), "b"),+ (((2 / 3, 1), (2 / 3, 1)), "c"),+ (((1, 4 / 3), (1, 4 / 3)), "a"),+ (((4 / 3, 5 / 3), (4 / 3, 5 / 3)), "b")+ ]+ it "works with zero-length queries (0)" $ do queryArc (fastCat [pure "a", pure "b"]) (Arc 0 0) `shouldBe` fmap toEvent [(((0, 0.5), (0, 0)), "a" :: String)]- it "1/3" $+ it "works with zero-length queries (1/3)" $ do queryArc (fastCat [pure "a", pure "b"]) (Arc (1 % 3) (1 % 3)) `shouldBe` fmap toEvent [(((0, 0.5), (1 % 3, 1 % 3)), "a" :: String)] @@ -123,17 +115,16 @@ b = "4 [5, 5] 6 7" :: Pattern Int c = "7 8 9 10" :: Pattern Int d = "7 [8, 9] 10 11" :: Pattern Int- it "creates silence when" $ do- it "first argument silent" $- comparePD- (Arc 0 1)- (silence |>| a)- silence- it "second argument silent" $- comparePD- (Arc 0 1)- (a |>| silence)- silence+ it "creates silence when first argument silent" $+ comparePD+ (Arc 0 1)+ (silence |>| a)+ silence+ it "creates silence when second argument silent" $+ comparePD+ (Arc 0 1)+ (a |>| silence)+ silence it "creates the same pattern when left argument has the same structure" $ comparePD (Arc 0 1)@@ -193,22 +184,21 @@ (Arc 0 1) (fast 1 x) x- it "mutes, when there is" $ do- it "silence in first argument" $- comparePD- (Arc 0 1)- (fast silence x)- silence- it "silence in second argument" $- comparePD- (Arc 0 1)- (fast x silence :: Pattern Time)- silence- it "speedup by 0" $- comparePD- (Arc 0 1)- (fast 0 x)- silence+ it "it mutes, when there is silence in first argument" $+ comparePD+ (Arc 0 1)+ (fast silence x)+ silence+ it "it mute, when there is silence in second argument" $+ comparePD+ (Arc 0 1)+ (fast x silence :: Pattern Time)+ silence+ it "it mute, when there is speedup by 0" $+ comparePD+ (Arc 0 1)+ (fast 0 x)+ silence it "is reciprocal to slow" $ comparePD (Arc 0 1)@@ -233,22 +223,21 @@ (Arc 0 10) (slow 1 x) x- it "mutes, when there is" $ do- it "silence in first argument" $- comparePD- (Arc 0 10)- (slow silence x)- silence- it "silence in second argument" $- comparePD- (Arc 0 10)- (slow x silence :: Pattern Time)- silence- it "speedup by 0" $- comparePD- (Arc 0 10)- (slow 0 x)- silence+ it "mutes, when there is silence in first argument" $+ comparePD+ (Arc 0 10)+ (slow silence x)+ silence+ it "mutes, when there is silence in second argument" $+ comparePD+ (Arc 0 10)+ (slow x silence :: Pattern Time)+ silence+ it "mutes, when it is speedup by 0" $+ comparePD+ (Arc 0 10)+ (slow 0 x)+ silence it "is reciprocal to fast" $ comparePD (Arc 0 10)@@ -291,16 +280,17 @@ (((0.5, 0.75), (0.5, 0.75)), 8) ] + describe "saw goes from 0 up to 1 every cycle" $ do+ it "0" $+ queryArc saw (Arc 0 0) `shouldBe` [Event (Context []) Nothing (Arc 0 0) 0 :: Event Double]+ it "0.25" $+ queryArc saw (Arc 0.25 0.25) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) 0.25 :: Event Double]+ it "0.5" $+ queryArc saw (Arc 0.5 0.5) `shouldBe` [Event (Context []) Nothing (Arc 0.5 0.5) 0.5 :: Event Double]+ it "0.75" $+ queryArc saw (Arc 0.75 0.75) `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) 0.75 :: Event Double]+ describe "saw" $ do- it "goes from 0 up to 1 every cycle" $ do- it "0" $- queryArc saw (Arc 0 0) `shouldBe` [Event (Context []) Nothing (Arc 0 0) 0 :: Event Double]- it "0.25" $- queryArc saw (Arc 0.25 0.25) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) 0.25 :: Event Double]- it "0.5" $- queryArc saw (Arc 0.5 0.5) `shouldBe` [Event (Context []) Nothing (Arc 0.5 0.5) 0.5 :: Event Double]- it "0.75" $- queryArc saw (Arc 0.75 0.75) `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) 0.75 :: Event Double] it "can be added to" $ map value (queryArc ((+ 1) <$> saw) (Arc 0.5 0.5)) `shouldBe` [1.5 :: Float] it "works on the left of <*>" $@@ -313,16 +303,15 @@ Event (Context []) Nothing (Arc 0.5 0.75) 3, Event (Context []) Nothing (Arc 0.75 1) 3 ]- it "can be reversed" $ do- it "works with whole cycles" $- queryArc (rev saw) (Arc 0 1)- `shouldBe` [Event (Context []) Nothing (Arc 0 1) 0 :: Event Double]- it "works with half cycles" $- queryArc (rev saw) (Arc 0.5 1)- `shouldBe` [Event (Context []) Nothing (Arc 0.5 1) 0 :: Event Double]- it "works with inset points" $- queryArc (rev saw) (Arc 0.25 0.25)- `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) 0.75 :: Event Double]+ it "works with whole cycles" $+ queryArc (rev saw) (Arc 0 1)+ `shouldBe` [Event (Context []) Nothing (Arc 0 1) 0 :: Event Double]+ it "works with half cycles" $+ queryArc (rev saw) (Arc 0.5 1)+ `shouldBe` [Event (Context []) Nothing (Arc 0.5 1) 0 :: Event Double]+ it "works with inset points" $+ queryArc (rev saw) (Arc 0.25 0.25)+ `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) 0.75 :: Event Double] describe "tri" $ do it "goes from 0 up to 1 and back every cycle" $
test/Sound/Tidal/ExceptionsTest.hs view
@@ -7,10 +7,10 @@ import Control.Exception import Data.Typeable () import Sound.Tidal.Pattern-import Test.Microspec+import Test.Hspec import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "NFData, forcing and catching exceptions" $ do describe "instance NFData (Pattern a)" $ do@@ -18,43 +18,6 @@ evaluate (rnf (Pattern undefined Nothing Nothing :: Pattern ())) `shouldThrow` anyException --- copied from http://hackage.haskell.org/package/hspec-expectations-0.8.2/docs/src/Test-Hspec-Expectations.html#shouldThrow--shouldThrow :: (Exception e) => IO a -> Selector e -> Microspec ()-action `shouldThrow` p = prop "shouldThrow" $- monadicIO $ do- r <- Test.Microspec.run $ try action- case r of- Right _ ->- -- "finished normally, but should throw exception: " ++ exceptionType- Test.Microspec.assert False- Left e ->- -- "threw exception that did not meet expectation")- Test.Microspec.assert $ p e--shouldNotThrow :: (Exception e) => IO a -> Selector e -> Microspec ()-action `shouldNotThrow` p = prop "shouldNotThrow" $- monadicIO $ do- r <- Test.Microspec.run $ try action- case r of- Right _ -> Test.Microspec.assert True- Left e -> Test.Microspec.assert $ p e---- a string repsentation of the expected exception's type-{--exceptionType = (show . typeOf . instanceOf) p- where- instanceOf :: Selector a -> a- instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance"--}---- |--- A @Selector@ is a predicate; it can simultaneously constrain the type and--- value of an exception.-type Selector a = (a -> Bool)--anyException :: Selector SomeException-anyException = const True anyErrorCall :: Selector ErrorCall anyErrorCall = const True
test/Sound/Tidal/ParamsTest.hs view
@@ -5,10 +5,10 @@ import Sound.Tidal.Core import Sound.Tidal.Params import Sound.Tidal.Pattern-import Test.Microspec+import Test.Hspec import TestUtils -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Params" $ do describe "VF params" $ do
test/Sound/Tidal/ParseTest.hs view
@@ -4,14 +4,13 @@ import Control.Exception import Sound.Tidal.Core-import Sound.Tidal.ExceptionsTest (anyException, shouldThrow, shouldNotThrow) import Sound.Tidal.Pattern import Sound.Tidal.UI (_degradeBy)-import Test.Microspec+import Test.Hspec import TestUtils import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Parse" $ do describe "parseBP_E" $ do@@ -342,14 +341,15 @@ ("a a |b b b|c c c c" :: Pattern String) ("[a a|b b b|c c c c]" :: Pattern String) it "'|' in list first" $ do- evaluate ("1 2@3|4|-|5!6|[7!8 9] 10 . 11 12*2 13!2 . 1@1" :: Pattern String)- `shouldNotThrow` anyException+ compareP+ (Arc 0 1)+ ("a|b b" :: Pattern String)+ ("[a|b b]" :: Pattern String) it "'|' in list last" $ do- evaluate ("12@1|23@1|12|[1 3!21]" :: Pattern String)- `shouldNotThrow` anyException- it "toplevel '|'" $ do- evaluate ("121|23@1|12|[1 321]" :: Pattern String)- `shouldNotThrow` anyException+ compareP+ (Arc 0 1)+ ("a b|c" :: Pattern String)+ ("[a b|c]" :: Pattern String) it "list is same as stack" $ do compareP (Arc 0 1)
test/Sound/Tidal/PatternTest.hs view
@@ -7,75 +7,56 @@ import Sound.Tidal.Core import Sound.Tidal.Pattern import Sound.Tidal.UI-import Test.Microspec+import Test.Hspec import TestUtils import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Pattern" $ do describe "Arc" $ do it "Arc is a Functor: Apply a given function to the start and end values of an Arc" $ do let res = fmap (+ 1) (Arc 3 5)- property $ ((Arc 4 6) :: Arc) === res-- {-- describe "Event" $ do- it "(Bifunctor) first: Apply a function to the Arc elements: whole and part" $ do- let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int- f = (+1)- property $- first f res ===- Event (Context []) (Just $ Arc 2 3) (Arc 4 5) 5- it "(Bifunctor) second: Apply a function to the event element" $ do- let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int- f = (+1)- property $- second f res ===- Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 6-}+ res `shouldBe` ((Arc 4 6) :: Arc) describe "whole" $ do it "returns the whole Arc in an Event" $ do- property $ (Just $ Arc 1 2) === whole (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int)+ (Just $ Arc 1 2) `shouldBe` whole (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int) describe "part" $ do it "returns the part Arc in an Event" $ do- property $ (Arc 3 4) === part (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int)+ (Arc 3 4) `shouldBe` part (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int) describe "value" $ do it "returns the event value in an Event" $ do- property $ 5 === value (Event (Context []) (Just $ Arc (1 :: Rational) 2) (Arc 3 4) (5 :: Int))+ 5 `shouldBe` value (Event (Context []) (Just $ Arc (1 :: Rational) 2) (Arc 3 4) (5 :: Int)) describe "wholeStart" $ do it "retrieve the onset of an event: the start of the whole Arc" $ do- property $ 1 === wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ 1 `shouldBe` wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventHasOnset" $ do it "return True when the start values of the two arcs in an event are equal" $ do let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int))- property $ True === eventHasOnset ev+ True `shouldBe` eventHasOnset ev it "return False when the start values of the two arcs in an event are not equal" $ do let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))- property $ False === eventHasOnset ev+ False `shouldBe` eventHasOnset ev describe "pure" $ do it "fills a whole cycle" $ do- property $ queryArc (pure 0) (Arc 0 1) === [(Event (Context []) (Just $ Arc 0 1) (Arc 0 1) (0 :: Int))]+ queryArc (pure 0) (Arc 0 1) `shouldBe` [(Event (Context []) (Just $ Arc 0 1) (Arc 0 1) (0 :: Int))] it "returns the part of an pure that you ask for, preserving the whole" $ do- property $ queryArc (pure 0) (Arc 0.25 0.75) === [(Event (Context []) (Just $ Arc 0 1) (Arc 0.25 0.75) (0 :: Int))]+ queryArc (pure 0) (Arc 0.25 0.75) `shouldBe` [(Event (Context []) (Just $ Arc 0 1) (Arc 0.25 0.75) (0 :: Int))] it "gives correct fragments when you go over cycle boundaries" $ do- property $- queryArc (pure 0) (Arc 0.25 1.25)- === [ (Event (Context []) (Just $ Arc 0 1) (Arc 0.25 1) (0 :: Int)),- (Event (Context []) (Just $ Arc 1 2) (Arc 1 1.25) 0)- ]+ queryArc (pure 0) (Arc 0.25 1.25)+ `shouldBe` [ (Event (Context []) (Just $ Arc 0 1) (Arc 0.25 1) (0 :: Int)),+ (Event (Context []) (Just $ Arc 1 2) (Arc 1 1.25) 0)] it "works with zero-length queries" $ do- it "0" $- queryArc (pure "a") (Arc 0 0)- `shouldBe` fmap toEvent [(((0, 1), (0, 0)), "a" :: String)]- it "1/3" $- queryArc (pure "a") (Arc (1 % 3) (1 % 3))- `shouldBe` fmap toEvent [(((0, 1), (1 % 3, 1 % 3)), "a" :: String)]+ queryArc (pure "a") (Arc 0 0)+ `shouldBe` fmap toEvent [(((0, 1), (0, 0)), "a" :: String)]+ queryArc (pure "a") (Arc (1 % 3) (1 % 3))+ `shouldBe` fmap toEvent [(((0, 1), (1 % 3, 1 % 3)), "a" :: String)] describe "_fastGap" $ do it "copes with cross-cycle queries" $ do@@ -105,22 +86,20 @@ (((0.5, 1), (0.5, 1)), 9) ] it "can take structure from the both sides" $ do- it "one" $- queryArc ((fastCat [pure (+ 1), pure (+ 2)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1)- `shouldBe` fmap- toEvent- [ (((0, 0.5), (0, 0.5)), 8 :: Int),- (((0.5, 1), (0.5, 1)), 10)- ]- it "two" $- queryArc ((fastCat [pure (+ 1), pure (+ 2), pure (+ 3)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1)- `shouldBe` fmap- toEvent- [ (((0 % 1, 1 % 3), (0 % 1, 1 % 3)), 8 :: Int),- (((1 % 3, 1 % 2), (1 % 3, 1 % 2)), 9),- (((1 % 2, 2 % 3), (1 % 2, 2 % 3)), 10),- (((2 % 3, 1 % 1), (2 % 3, 1 % 1)), 11)- ]+ queryArc ((fastCat [pure (+ 1), pure (+ 2)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1)+ `shouldBe` fmap+ toEvent+ [ (((0, 0.5), (0, 0.5)), 8 :: Int),+ (((0.5, 1), (0.5, 1)), 10)+ ]+ queryArc ((fastCat [pure (+ 1), pure (+ 2), pure (+ 3)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1)+ `shouldBe` fmap+ toEvent+ [ (((0 % 1, 1 % 3), (0 % 1, 1 % 3)), 8 :: Int),+ (((1 % 3, 1 % 2), (1 % 3, 1 % 2)), 9),+ (((1 % 2, 2 % 3), (1 % 2, 2 % 3)), 10),+ (((2 % 3, 1 % 1), (2 % 3, 1 % 1)), 11)+ ] it "obeys pure id <*> v = v" $ do let v = (fastCat [fastCat [pure 7, pure 8], pure 9]) :: Pattern Int queryArc ((pure id <*> v)) (Arc 0 5) `shouldBe` queryArc v (Arc 0 5)@@ -155,10 +134,9 @@ (((0, 1), (0.5, 1)), 9 :: Int) ] - describe "*>" $ do- it "can apply a pattern of values to a pattern of functions" $ do- it "works within cycles" $ queryArc ((pure (+ 1)) *> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0, 1), (0, 1)), 4 :: Int)]- it "works across cycles" $ queryArc ((pure (+ 1)) *> (slow 2 $ pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0, 2), (0, 1)), 4 :: Int)]+ describe "*> can apply a pattern of values to a pattern of functions" $ do+ it "works within cycles" $ queryArc ((pure (+ 1)) *> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0, 1), (0, 1)), 4 :: Int)]+ it "works across cycles" $ queryArc ((pure (+ 1)) *> (slow 2 $ pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0, 2), (0, 1)), 4 :: Int)] it "doesn't take structure from the left" $ do queryArc (pure (+ 1) *> (fastCat [pure 7, pure 8])) (Arc 0 1) `shouldBe` fmap@@ -169,29 +147,24 @@ describe "arcCycles" $ do it "leaves a unit cycle intact" $ do- it "(0,1)" $ arcCycles (Arc 0 1) `shouldBe` [(Arc 0 1)]- it "(3,4)" $ arcCycles (Arc 3 4) `shouldBe` [(Arc 3 4)]+ arcCycles (Arc 0 1) `shouldBe` [(Arc 0 1)]+ arcCycles (Arc 3 4) `shouldBe` [(Arc 3 4)] it "splits a cycle at cycle boundaries" $ do- it "(0,1.1)" $ arcCycles (Arc 0 1.1) `shouldBe` [(Arc 0 1), (Arc 1 1.1)]- it "(1,2,1)" $ arcCycles (Arc 1 2.1) `shouldBe` [(Arc 1 2), (Arc 2 2.1)]- it "(3 + (1%3),5.1)" $- arcCycles (Arc (3 + (1 % 3)) 5.1) `shouldBe` [(Arc (3 + (1 % 3)) 4), (Arc 4 5), (Arc 5 5.1)]+ arcCycles (Arc 0 1.1) `shouldBe` [(Arc 0 1), (Arc 1 1.1)]+ arcCycles (Arc 1 2.1) `shouldBe` [(Arc 1 2), (Arc 2 2.1)]+ arcCycles (Arc (3 + (1 % 3)) 5.1) `shouldBe` [(Arc (3 + (1 % 3)) 4), (Arc 4 5), (Arc 5 5.1)] describe "unwrap" $ do it "preserves inner structure" $ do- it "one" $- (queryArc (unwrap $ pure (fastCat [pure "a", pure ("b" :: String)])) (Arc 0 1))- `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1))- it "two" $- (queryArc (unwrap $ pure (fastCat [pure "a", pure "b", fastCat [pure "c", pure ("d" :: String)]])) (Arc 0 1))- `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1))+ (queryArc (unwrap $ pure (fastCat [pure "a", pure ("b" :: String)])) (Arc 0 1))+ `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1))+ (queryArc (unwrap $ pure (fastCat [pure "a", pure "b", fastCat [pure "c", pure ("d" :: String)]])) (Arc 0 1))+ `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1)) it "preserves outer structure" $ do- it "one" $- (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure ("b" :: String)]) (Arc 0 1))- `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1))- it "two" $- (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure "b", fastCat [pure $ pure "c", pure $ pure ("d" :: String)]]) (Arc 0 1))- `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1))+ (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure ("b" :: String)]) (Arc 0 1))+ `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1))+ (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure "b", fastCat [pure $ pure "c", pure $ pure ("d" :: String)]]) (Arc 0 1))+ `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1)) it "gives events whole/part timespans that are an intersection of that of inner and outer events" $ do let a = fastCat [pure "a", pure "b"] b = fastCat [pure "c", pure "d", pure "e"]@@ -247,22 +220,18 @@ describe "rotR" $ do it "works over two cycles" $- property $- comparePD (Arc 0 2) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String))+ comparePD (Arc 0 2) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) it "works over one cycle" $- property $- compareP (Arc 0 1) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String))+ compareP (Arc 0 1) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) it "works with zero width queries" $- property $- compareP (Arc 0 0) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String))+ compareP (Arc 0 0) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) describe "comparePD" $ do it "allows split events to be compared" $- property $- comparePD- (Arc 0 2)- (splitQueries $ _slow 2 $ pure ("a" :: String))- (_slow 2 $ pure "a")+ comparePD+ (Arc 0 2)+ (splitQueries $ _slow 2 $ pure ("a" :: String))+ (_slow 2 $ pure "a") describe "controlI" $ do it "can retrieve values from state" $@@ -271,290 +240,283 @@ describe "wholeStart" $ do it "retrieve first element of a tuple, inside first element of a tuple, inside the first of another" $ do- property $ 1 === wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ 1 `shouldBe` wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "wholeStop" $ do it "retrieve the end time from the first Arc in an Event" $ do- property $ 2 === wholeStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ 2 `shouldBe` wholeStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPartStart" $ do it "retrieve the start time of the second Arc in an Event" $ do- property $ 3 === eventPartStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ 3 `shouldBe` eventPartStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPartStop" $ do it "retrieve the end time of the second Arc in an Event" $ do- property $ 4 === eventPartStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ 4 `shouldBe` eventPartStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPart" $ do it "retrieve the second Arc in an Event" $ do- property $ Arc 3 4 === eventPart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ Arc 3 4 `shouldBe` eventPart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventValue" $ do it "retrieve the second value from a tuple" $ do- property $ 5 === eventValue (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ 5 `shouldBe` eventValue (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventHasOnset" $ do it "return True when the start values of the two arcs in an event are equal" $ do let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int))- property $ True === eventHasOnset ev+ True `shouldBe` eventHasOnset ev it "return False when the start values of the two arcs in an event are not equal" $ do let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))- property $ False === eventHasOnset ev+ False `shouldBe` eventHasOnset ev describe "sam" $ do it "start of a cycle, round down time value" $ do let res = sam (3.4 :: Time)- property $ (3.0 :: Time) === res+ (3.0 :: Time) `shouldBe` res describe "nextSam" $ do it "the end point of the current cycle, and start of the next" $ do let res = nextSam (3.4 :: Time)- property $ (4.0 :: Time) === res+ (4.0 :: Time) `shouldBe` res describe "arcCycles" $ do it "if start time is greater than end time return empty list" $ do let res = arcCycles (Arc 2.3 2.1)- property $ [] === res+ [] `shouldBe` res it "if start time is equal to end time return empty list" $ do let res = arcCycles (Arc 3 3)- property $ [] === res+ [] `shouldBe` res it "if start and end time round down to same value return list of (start, end)" $ do let res = arcCycles (Arc 2.1 2.3)- property $ [(Arc 2.1 2.3)] === res+ [(Arc 2.1 2.3)] `shouldBe` res it "if start time is less than end time and start time does not round down to same value as end time" $ do let res = arcCycles (Arc 2.1 3.3)- property $ [(Arc 2.1 3.0), (Arc 3.0 3.3)] === res+ [(Arc 2.1 3.0), (Arc 3.0 3.3)] `shouldBe` res describe "arcCyclesZW" $ do it "if start and end time are equal return list of (start, end)" $ do let res = arcCyclesZW (Arc 2.5 2.5)- property $ [(Arc 2.5 2.5)] === res+ [(Arc 2.5 2.5)] `shouldBe` res it "if start and end time are not equal call arcCycles (start, end) with same rules as above" $ do let res = arcCyclesZW (Arc 2.3 2.1)- property $ [] === res+ [] `shouldBe` res it "if start time is less than end time" $ do let res = arcCyclesZW (Arc 2.1 2.3)- property $ [(Arc 2.1 2.3)] === res+ [(Arc 2.1 2.3)] `shouldBe` res it "if start time is greater than end time" $ do let res = arcCyclesZW (Arc 2.1 3.3)- property $ [(Arc 2.1 3.0), (Arc 3.0 3.3)] === res+ [(Arc 2.1 3.0), (Arc 3.0 3.3)] `shouldBe` res describe "mapCycle" $ do it "Apply a function to the Arc values minus the start value rounded down (sam'), adding both results to sam' to obtain the new Arc value" $ do let res = mapCycle (* 2) (Arc 3.3 5)- property $ ((Arc 3.6 7.0) :: Arc) === res+ ((Arc 3.6 7.0) :: Arc) `shouldBe` res describe "toTime" $ do it "Convert a number of type Real to a Time value of type Rational, Int test" $ do let res = toTime (3 :: Int)- property $ (3 % 1 :: Time) === res+ (3 % 1 :: Time) `shouldBe` res it "Convert a number of type Double to a Time value of type Rational" $ do let res = toTime (3.2 :: Double)- property $ (3602879701896397 % 1125899906842624 :: Time) === res+ (3602879701896397 % 1125899906842624 :: Time) `shouldBe` res describe "cyclePos" $ do it "Subtract a Time value from its value rounded down (the start of the cycle)" $ do let res = cyclePos 2.6- property $ (0.6 :: Time) === res+ (0.6 :: Time) `shouldBe` res it "If no difference between a given Time and the start of the cycle" $ do let res = cyclePos 2- property $ (0.0 :: Time) === res+ (0.0 :: Time) `shouldBe` res describe "isIn" $ do it "Check given Time is inside a given Arc value, Time is greater than start and less than end Arc values" $ do let res = isIn (Arc 2.0 2.8) 2.5- property $ True === res+ True `shouldBe` res it "Given Time is equal to the Arc start value" $ do let res = isIn (Arc 2.0 2.8) 2.0- property $ True === res+ True `shouldBe` res it "Given Time is less than the Arc start value" $ do let res = isIn (Arc 2.0 2.8) 1.4- property $ False === res+ False `shouldBe` res it "Given Time is greater than the Arc end value" $ do let res = isIn (Arc 2.0 2.8) 3.2- property $ False === res+ False `shouldBe` res describe "onsetIn" $ do it "If the beginning of an Event is within a given Arc, same rules as 'isIn'" $ do let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.2 2.7) (Arc 3.3 3.8) (5 :: Int))- property $ True === res+ True `shouldBe` res it "Beginning of Event is equal to beggining of given Arc" $ do let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.0 2.7) (Arc 3.3 3.8) (5 :: Int))- property $ True === res+ True `shouldBe` res it "Beginning of an Event is less than the start of the Arc" $ do let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 1.2 1.7) (Arc 3.3 3.8) (5 :: Int))- property $ False === res+ False `shouldBe` res it "Start of Event is greater than the start of the given Arc" $ do let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 3.1 3.5) (Arc 4.0 4.6) (5 :: Int))- property $ False === res+ False `shouldBe` res describe "subArc" $ do it "Checks if an Arc is within another, returns Just (max $ (fst a1) (fst a2), min $ (snd a1) (snd a2)) if so, otherwise Nothing" $ do let res = subArc (Arc 2.1 2.4) (Arc 2.4 2.8)- property $ Nothing === res+ Nothing `shouldBe` res it "if max (fst arc1) (fst arc2) <= min (snd arc1) (snd arc2) return Just (max (fst arc1) (fst arc2), min...)" $ do let res = subArc (Arc 2 2.8) (Arc 2.4 2.9)- property $ Just (Arc 2.4 2.8) === res+ Just (Arc 2.4 2.8) `shouldBe` res describe "timeToCycleArc" $ do it "given a Time value return the Arc in which it resides" $ do let res = timeToCycleArc 2.2- property $ (Arc 2.0 3.0) === res+ (Arc 2.0 3.0) `shouldBe` res describe "cyclesInArc" $ do it "Return a list of cycles in a given arc, if start is greater than end return empty list" $ do let res = cyclesInArc (Arc 2.4 2.2)- property $ ([] :: [Int]) === res+ ([] :: [Int]) `shouldBe` res it "If start value of Arc is equal to end value return list with start value rounded down" $ do let res = cyclesInArc (Arc 2.4 2.4)- property $ ([2] :: [Int]) === res+ ([2] :: [Int]) `shouldBe` res it "if start of Arc is less than end return list of start rounded down to end rounded up minus one" $ do let res = cyclesInArc (Arc 2.2 4.5)- property $ ([2, 3, 4] :: [Int]) === res+ ([2, 3, 4] :: [Int]) `shouldBe` res describe "cycleArcsInArc" $ do it "generates a list of Arcs based on the cycles found within a given a Arc" $ do let res = cycleArcsInArc (Arc 2.2 4.5)- property $ [(Arc 2.0 3.0), (Arc 3.0 4.0), (Arc 4.0 5.0)] === res+ [(Arc 2.0 3.0), (Arc 3.0 4.0), (Arc 4.0 5.0)] `shouldBe` res describe "isAdjacent" $ do it "if the given Events are adjacent parts of the same whole" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int))- property $ True === res+ True `shouldBe` res it "if first Arc of of first Event is not equal to first Arc of second Event" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int))- property $ False === res+ False `shouldBe` res it "if the value of the first Event does not equal the value of the second Event" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (6 :: Int))- property $ False === res+ False `shouldBe` res it "second value of second Arc of first Event not equal to first value of second Arc in second Event..." $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))- property $ False === res+ False `shouldBe` res describe "defragParts" $ do it "if empty list with no events return empty list" $ do let res = defragParts ([] :: [Event Int])- property $ [] === res+ [] `shouldBe` res it "if list consists of only one Event return it as is" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))]- property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] === res+ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] `shouldBe` res it "if list contains adjacent Events return list with Parts combined" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)), (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int))]- property $ [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5)] === res+ [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5)] `shouldBe` res it "if list contains more than one Event none of which are adjacent, return List as is" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5), (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int))]- property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5, Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)] === res+ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5, Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)] `shouldBe` res describe "sect" $ do it "take two Arcs and return - Arc (max of two starts) (min of two ends)" $ do let res = sect (Arc 2.2 3) (Arc 2 2.9)- property $ Arc 2.2 2.9 == res+ Arc 2.2 2.9 == res describe "hull" $ do it "take two Arcs anre return - Arc (min of two starts) (max of two ends)" $ do let res = hull (Arc 2.2 3) (Arc 2 2.9)- property $ Arc 2 3 == res+ Arc 2 3 == res describe "withResultArc" $ do it "apply given function to the Arcs" $ do let p = withResultArc (+ 5) (stripContext $ fast "1 2" "3 4" :: Pattern Int) let res = queryArc p (Arc 0 1)- property $ res === fmap toEvent [(((5, 11 % 2), (5, 11 % 2)), 3), (((11 % 2, 23 % 4), (11 % 2, 23 % 4)), 3), (((23 % 4, 6), (23 % 4, 6)), 4)]+ res `shouldBe` fmap toEvent [(((5, 11 % 2), (5, 11 % 2)), 3), (((11 % 2, 23 % 4), (11 % 2, 23 % 4)), 3), (((23 % 4, 6), (23 % 4, 6)), 4)] describe "applyFIS" $ do it "apply Float function when value of type VF" $ do let res = applyFIS (+ 1) (+ 1) (++ "1") (VF 1)- property $ (VF 2.0) === res+ (VF 2.0) `shouldBe` res it "apply Int function when value of type VI" $ do let res = applyFIS (+ 1) (+ 1) (++ "1") (VI 1)- property $ (VI 2) === res+ (VI 2) `shouldBe` res it "apply String function when value of type VS" $ do let res = applyFIS (+ 1) (+ 1) (++ "1") (VS "1")- property $ (VS "11") === res+ (VS "11") `shouldBe` res describe "fNum2" $ do it "apply Int function for two Int values" $ do let res = fNum2 (+) (+) (VI 2) (VI 3)- property $ (VI 5) === res+ (VI 5) `shouldBe` res it "apply float function when given two float values" $ do let res = fNum2 (+) (+) (VF 2) (VF 3)- property $ (VF 5.0) === res+ (VF 5.0) `shouldBe` res it "apply float function when one float and one int value given" $ do let res = fNum2 (+) (+) (VF 2) (VI 3)- property $ (VF 5.0) === res+ (VF 5.0) `shouldBe` res describe "getI" $ do it "get Just value when Int value is supplied" $ do let res = getI (VI 3)- property $ (Just 3) === res+ (Just 3) `shouldBe` res it "get floored value when float value is supplied" $ do let res = getI (VF 3.5)- property $ (Just 3) === res+ (Just 3) `shouldBe` res it "get if String value is supplied" $ do let res = getI (VS "3")- property $ Nothing === res+ Nothing `shouldBe` res describe "getF" $ do it "get Just value when Float value is supplied" $ do let res = getF (VF 3)- property $ (Just 3.0) === res+ (Just 3.0) `shouldBe` res it "get converted value if Int value is supplied" $ do let res = getF (VI 3)- property $ (Just 3.0) === res+ (Just 3.0) `shouldBe` res describe "getS" $ do it "get Just value when String value is supplied" $ do let res = getS (VS "Tidal")- property $ (Just "Tidal") === res+ (Just "Tidal") `shouldBe` res it "get Nothing if Int value is not supplied" $ do let res = getS (VI 3)- property $ Nothing === res+ Nothing `shouldBe` res describe "filterValues" $ do it "remove Events above given threshold" $ do let fil = filterValues (< 2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time let res = queryArc fil (Arc 0.5 1.5)- property $ fmap toEvent [(((1, 4 % 3), (1, 4 % 3)), 1 % 1)] === res+ fmap toEvent [(((1, 4 % 3), (1, 4 % 3)), 1 % 1)] `shouldBe` res it "remove Events below given threshold" $ do let fil = filterValues (> 2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time let res = queryArc fil (Arc 0.5 1.5)- property $ fmap toEvent [(((2 % 3, 1), (2 % 3, 1)), 3 % 1)] === res+ fmap toEvent [(((2 % 3, 1), (2 % 3, 1)), 3 % 1)] `shouldBe` res describe "filterWhen" $ do it "filter below given threshold" $ do let fil = filterWhen (< 0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 let res = queryArc fil (Arc 0.5 1.5)- property $ [] === res+ [] `shouldBe` res it "filter above given threshold" $ do let fil = stripContext $ filterWhen (> 0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 let res = queryArc fil (Arc 0.5 1.5)- property $ fmap toEvent [(((3 % 4, 1), (3 % 4, 1)), 1.5), (((1, 5 % 4), (1, 5 % 4)), 1), (((5 % 4, 3 % 2), (5 % 4, 3 % 2)), 1.5)] === res+ fmap toEvent [(((3 % 4, 1), (3 % 4, 1)), 1.5), (((1, 5 % 4), (1, 5 % 4)), 1), (((5 % 4, 3 % 2), (5 % 4, 3 % 2)), 1.5)] `shouldBe` res describe "compressArc" $ do it "return empty if start time is greater than end time" $ do let res = queryArc (compressArc (Arc 0.8 0.1) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2)- property $ [] === res+ [] `shouldBe` res it "return empty if start time or end time are greater than 1" $ do let res = queryArc (compressArc (Arc 0.1 2) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2)- property $ [] === res+ [] `shouldBe` res it "return empty if start or end are less than zero" $ do let res = queryArc (compressArc (Arc (-0.8) 0.1) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2)- property $ [] === res+ [] `shouldBe` res it "otherwise compress difference between start and end values of Arc" $ do let p = fast "1 2" "3 4" :: Pattern Time let res = queryArc (stripContext $ compressArc (Arc 0.2 0.8) p) (Arc 0 1) let expected = fmap toEvent [(((1 % 5, 1 % 2), (1 % 5, 1 % 2)), 3 % 1), (((1 % 2, 13 % 20), (1 % 2, 13 % 20)), 3 % 1), (((13 % 20, 4 % 5), (13 % 20, 4 % 5)), 4 % 1)]- property $ expected === res+ expected `shouldBe` res --- pending "Sound.Tidal.Pattern.eventL" $ do--- it "succeeds if the first event 'whole' is shorter" $ do--- property $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1.1)) "x")--- it "fails if the events are the same length" $ do--- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1)) "x")--- it "fails if the second event is shorter" $ do--- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 0.5)) "x")
test/Sound/Tidal/ScalesTest.hs view
@@ -4,11 +4,11 @@ import Sound.Tidal.Pattern import Sound.Tidal.Scales-import Test.Microspec+import Test.Hspec import TestUtils import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Scales" $ do describe "scale" $ do
test/Sound/Tidal/StepwiseTest.hs view
@@ -8,22 +8,17 @@ import Sound.Tidal.ParseBP () import Sound.Tidal.Pattern ( ArcF (Arc),- Pattern (tactus),+ Pattern (steps), fast, rev, ) import Sound.Tidal.Stepwise (expand, stepcat, stepdrop, steptake) import Sound.Tidal.UI (inv, iter, linger, segment)-import Test.Microspec- ( MTestable (describe),- Microspec,- it,- shouldBe,- )-import TestUtils (compareP, firstCycleValues)+import Test.Hspec (Spec, describe, it, shouldBe)+import TestUtils (compareP) import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Stepwise" $ do describe "stepcat" $ do@@ -33,133 +28,22 @@ it "can pattern expands" $ do compareP (Arc 0 8) (expand "2 1" ("a b c" :: Pattern Char)) "a@2 b@2 c@2 a b c" describe "steptake" $ do- it "can pattern takes" $ do+ it "can pattern steptakes" $ do compareP (Arc 0 8) (steptake "1 2 3 4" ("a b c d" :: Pattern Char)) "a a b a b c a b c d"- it "can pattern reverse takes" $ do+ it "can pattern reverse steptakes" $ do compareP (Arc 0 8) (steptake "-1 -2 -3 -4" ("a b c d" :: Pattern Char)) "d c d b c d a b c d" describe "stepdrop" $ do- it "can pattern drops" $ do+ it "can pattern stepdrops" $ do compareP (Arc 0 8) (stepdrop "0 1 2 3" ("a b c d" :: Pattern Char)) "a b c d a b c a b a"- it "can pattern reverse drops" $ do+ it "can pattern reverse stepdrops" $ do compareP (Arc 0 8) (stepdrop "0 -1 -2 -3" ("a b c d" :: Pattern Char)) "a b c d b c d c d d"- describe "tactus" $ do- it "is correctly preserved/calculated through transformations" $ do- it "linger" $ (firstCycleValues <$> tactus (linger 4 "a b c" :: Pattern Char)) `shouldBe` Just [3]- it "iter" $ (firstCycleValues <$> tactus (iter 4 "a b c" :: Pattern Char)) `shouldBe` Just [3]- it "fast" $ (firstCycleValues <$> tactus (fast 4 "a b c" :: Pattern Char)) `shouldBe` Just [3]- it "hurry" $ (firstCycleValues <$> tactus (hurry 4 $ sound "a b c")) `shouldBe` Just [3]- it "rev" $ (firstCycleValues <$> tactus (rev "a b c" :: Pattern Char)) `shouldBe` Just [3]- it "segment" $ (firstCycleValues <$> tactus (segment 10 "a" :: Pattern Char)) `shouldBe` Just [10]- it "invert" $ (firstCycleValues <$> tactus (inv "1 0 1" :: Pattern Bool)) `shouldBe` Just [3]- it "chop" $ (firstCycleValues <$> tactus (chop 3 $ sound "a b")) `shouldBe` Just [6]- it "chop" $ (firstCycleValues <$> tactus (striate 3 $ sound "a b")) `shouldBe` Just [6]---- expect(sequence({ s: 'bev' }, { s: 'amenbreak' }).chop(4).tactus).toStrictEqual(Fraction(8));--- expect(sequence({ s: 'bev' }, { s: 'amenbreak' }).striate(4).tactus).toStrictEqual(Fraction(8));--- expect(sequence({ s: 'bev' }, { s: 'amenbreak' }).slice(4, sequence(0, 1, 2, 3)).tactus).toStrictEqual(--- Fraction(4),--- );--- expect(sequence({ s: 'bev' }, { s: 'amenbreak' }).splice(4, sequence(0, 1, 2, 3)).tactus).toStrictEqual(--- Fraction(4),--- );--- expect(sequence({ n: 0 }, { n: 1 }, { n: 2 }).chop(4).tactus).toStrictEqual(Fraction(12));--- expect(--- pure((x) => x + 1)--- .setTactus(3)--- .appBoth(pure(1).setTactus(2)).tactus,--- ).toStrictEqual(Fraction(6));--- expect(--- pure((x) => x + 1)--- .setTactus(undefined)--- .appBoth(pure(1).setTactus(2)).tactus,--- ).toStrictEqual(Fraction(2));--- expect(--- pure((x) => x + 1)--- .setTactus(3)--- .appBoth(pure(1).setTactus(undefined)).tactus,--- ).toStrictEqual(Fraction(3));--- expect(stack(fastcat(0, 1, 2), fastcat(3, 4)).tactus).toStrictEqual(Fraction(6));--- expect(stack(fastcat(0, 1, 2), fastcat(3, 4).setTactus(undefined)).tactus).toStrictEqual(Fraction(3));--- expect(stackLeft(fastcat(0, 1, 2, 3), fastcat(3, 4)).tactus).toStrictEqual(Fraction(4));--- expect(stackRight(fastcat(0, 1, 2), fastcat(3, 4)).tactus).toStrictEqual(Fraction(3));--- // maybe this should double when they are either all even or all odd--- expect(stackCentre(fastcat(0, 1, 2), fastcat(3, 4)).tactus).toStrictEqual(Fraction(3));--- expect(fastcat(0, 1).ply(3).tactus).toStrictEqual(Fraction(6));--- expect(fastcat(0, 1).setTactus(undefined).ply(3).tactus).toStrictEqual(undefined);--- expect(fastcat(0, 1).fast(3).tactus).toStrictEqual(Fraction(2));--- expect(fastcat(0, 1).setTactus(undefined).fast(3).tactus).toStrictEqual(undefined);--- });--- });--- describe('stepcat', () => {--- it('can cat', () => {--- expect(sameFirst(stepcat(fastcat(0, 1, 2, 3), fastcat(4, 5)), fastcat(0, 1, 2, 3, 4, 5)));--- expect(sameFirst(stepcat(pure(1), pure(2), pure(3)), fastcat(1, 2, 3)));--- });--- it('calculates undefined tactuses as the average', () => {--- expect(sameFirst(stepcat(pure(1), pure(2), pure(3).setTactus(undefined)), fastcat(1, 2, 3)));--- });--- });--- describe('taper', () => {--- it('can taper', () => {--- expect(sameFirst(sequence(0, 1, 2, 3, 4).taper(1, 5), sequence(0, 1, 2, 3, 4, 0, 1, 2, 3, 0, 1, 2, 0, 1, 0)));--- });--- it('can taper backwards', () => {--- expect(sameFirst(sequence(0, 1, 2, 3, 4).taper(-1, 5), sequence(0, 0, 1, 0, 1, 2, 0, 1, 2, 3, 0, 1, 2, 3, 4)));--- });--- });--- describe('increase and decrease', () => {--- it('can increase from the left', () => {--- expect(sameFirst(sequence(0, 1, 2, 3, 4).increase(2), sequence(0, 1)));--- });--- it('can decrease to the left', () => {--- expect(sameFirst(sequence(0, 1, 2, 3, 4).decrease(2), sequence(0, 1, 2)));--- });--- it('can increase from the right', () => {--- expect(sameFirst(sequence(0, 1, 2, 3, 4).increase(-2), sequence(3, 4)));--- });--- it('can decrease to the right', () => {--- expect(sameFirst(sequence(0, 1, 2, 3, 4).decrease(-2), sequence(2, 3, 4)));--- });--- it('can decrease nothing', () => {--- expect(sameFirst(pure('a').decrease(0), pure('a')));--- });--- it('can decrease nothing, repeatedly', () => {--- expect(sameFirst(pure('a').decrease(0, 0), fastcat('a', 'a')));--- for (var i = 0; i < 100; ++i) {--- expect(sameFirst(pure('a').decrease(...Array(i).fill(0)), fastcat(...Array(i).fill('a'))));--- }--- });--- });--- describe('expand', () => {--- it('can expand four things in half', () => {--- expect(--- sameFirst(sequence(0, 1, 2, 3).expand(1, 0.5), stepcat(sequence(0, 1, 2, 3), sequence(0, 1, 2, 3).expand(0.5))),--- );--- });--- it('can expand five things in half', () => {--- expect(--- sameFirst(--- sequence(0, 1, 2, 3, 4).expand(1, 0.5),--- stepcat(sequence(0, 1, 2, 3, 4), sequence(0, 1, 2, 3, 4).expand(0.5)),--- ),--- );--- });--- });--- describe('stepJoin', () => {--- it('can join a pattern with a tactus of 2', () => {--- expect(--- sameFirst(--- sequence(pure(pure('a')), pure(pure('b').setTactus(2))).stepJoin(),--- stepcat(pure('a'), pure('b').setTactus(2)),--- ),--- );--- });--- it('can join a pattern with a tactus of 0.5', () => {--- expect(--- sameFirst(--- sequence(pure(pure('a')), pure(pure('b').setTactus(0.5))).stepJoin(),--- stepcat(pure('a'), pure('b').setTactus(0.5)),--- ),--- );--- });--- });+ describe "step count is correctly preserved/calculated through transformations" $ do+ it "linger" $ steps (linger 4 "a b c" :: Pattern Char) `shouldBe` Just 3+ it "iter" $ steps (iter 4 "a b c" :: Pattern Char) `shouldBe` Just 3+ it "fast" $ steps (fast 4 "a b c" :: Pattern Char) `shouldBe` Just 3+ it "hurry" $ steps (hurry 4 $ sound "a b c") `shouldBe` Just 3+ it "rev" $ steps (rev "a b c" :: Pattern Char) `shouldBe` Just 3+ it "segment" $ steps (segment 10 "a" :: Pattern Char) `shouldBe` Just 10+ it "invert" $ steps (inv "1 0 1" :: Pattern Bool) `shouldBe` Just 3+ it "chop" $ steps (chop 3 $ sound "a b") `shouldBe` Just 6+ it "chop" $ steps (striate 3 $ sound "a b") `shouldBe` Just 6
test/Sound/Tidal/UITest.hs view
@@ -4,17 +4,18 @@ import qualified Data.Map.Strict as Map -- import Sound.Tidal.Pattern-import Sound.Tidal.Control+import Sound.Tidal.Control ( _chop ) import Sound.Tidal.Core-import Sound.Tidal.Params-import Sound.Tidal.ParseBP+ ( sig, sine, saw, (|+), (>|), (#), run, cat, fastcat, (<~) )+import Sound.Tidal.Params ( sound, begin, crush, end, n, speed, s )+import Sound.Tidal.ParseBP ( parseBP_E ) import Sound.Tidal.Pattern import Sound.Tidal.UI-import Test.Microspec-import TestUtils+import Test.Hspec ( describe, it, shouldBe, Spec )+import TestUtils ( compareP, comparePD, compareTol, ps ) import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.UI" $ do describe "_chop" $ do@@ -27,10 +28,9 @@ compareP (Arc 0 1) (slow 2 $ _chop 2 $ s (pure "a"))- (begin (pure 0) # end (pure 0.5) # (s (pure "a")))+ (begin (pure 0) # end (pure 0.5) # s (pure "a")) it "can chop a chop" $- property $- compareTol (Arc 0 1) (_chop 6 $ s $ pure "a") (_chop 2 $ _chop 3 $ s $ pure "a")+ compareTol (Arc 0 1) (_chop 6 $ s $ pure "a") (_chop 2 $ _chop 3 $ s $ pure "a") describe "segment" $ do it "can turn a single event into multiple events" $ do@@ -104,39 +104,35 @@ in compareP overTimeSpan testMe expectedResult describe "rand" $ do- it "generates a (pseudo-)random number between zero & one" $ do- it "at the start of a cycle" $- (queryArc rand (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (0 :: Float)]- it "at 1/4 of a cycle" $- (queryArc rand (Arc 0.25 0.25))- `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (0.6295689214020967 :: Float)]- it "at 3/4 of a cycle" $- (queryArc rand (Arc 0.75 0.75))+ it "it generates a (pseudo-)random number between 0 and 1 at the start of a cycle" $+ (queryArc rand (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (0.5 :: Float)]+ it "it generates a (pseudo-)random number between 0 and 1 at 1/4 of a cycle" $+ (queryArc rand (Arc 0.25 0.25))+ `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (0.6295689214020967 :: Float)]+ it "it generates a (pseudo-)random number between 0 and 1 at 3/4 of a cycle" $+ (queryArc rand (Arc 0.75 0.75)) `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (0.20052618719637394 :: Float)] describe "irand" $ do- it "generates a (pseudo-random) integer between zero & i" $ do- it "at the start of a cycle" $- (queryArc (irand 10) (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (0 :: Int)]- it "at 1/4 of a cycle" $- (queryArc (irand 10) (Arc 0.25 0.25)) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (6 :: Int)]- it "is patternable" $- (queryArc (irand "10 2") (Arc 0 1))- `shouldBe` [ Event (Context [((1, 1), (3, 1))]) Nothing (Arc 0 0.5) (6 :: Int),- Event (Context [((4, 1), (5, 1))]) Nothing (Arc 0.5 1) (0 :: Int)- ]+ -- it "generates a (pseudo-random) integer between zero & i" $ do+ it "at the start of a cycle" $+ (queryArc (irand 10) (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (5 :: Int)]+ it "at 1/4 of a cycle" $+ (queryArc (irand 10) (Arc 0.25 0.25)) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (6 :: Int)]+ it "is patternable" $+ (queryArc (irand "10 2") (Arc 0 1))+ `shouldBe` [ Event (Context [((1, 1), (3, 1))]) Nothing (Arc 0 0.5) (5 :: Int),+ Event (Context [((4, 1), (5, 1))]) Nothing (Arc 0.5 1) (0 :: Int)+ ] describe "normal" $ do- it "produces values within [0,1] in a bell curve" $ do- it "at the start of a cycle" $- queryArc normal (Arc 0 0.1)- `shouldBe` [Event (Context []) Nothing (Arc 0 0.1) (0.4614205864457064 :: Double)]- it "at 1/4 of a cycle" $- queryArc normal (Arc 0.25 0.25)- `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (0.5 :: Double)]- it "at 3/4 of a cycle" $- queryArc normal (Arc 0.75 0.75)- `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (0.5 :: Double)]+ it "produces values within [0,1] in a bell curve at different parts of a cycle" $ do+ queryArc normal (Arc 0 0.1)+ `shouldBe` [Event (Context []) Nothing (Arc 0 0.1) (0.42461738824387246 :: Double)]+ queryArc normal (Arc 0.25 0.25)+ `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (0.5 :: Double)]+ queryArc normal (Arc 0.75 0.75)+ `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (0.5 :: Double)] describe "range" $ do describe "scales a pattern to the supplied range" $ do@@ -174,19 +170,16 @@ describe "rot" $ do it "rotates values in a pattern irrespective of structure" $- property $ comparePD (Arc 0 2) (rot 1 "a ~ b c" :: Pattern String) ("b ~ c a" :: Pattern String) it "works with negative values" $- property $ comparePD (Arc 0 2) (rot (-1) "a ~ b c" :: Pattern String) ("c ~ a b" :: Pattern String) it "works with complex patterns" $- property $ comparePD (Arc 0 2) (rot (1) "a ~ [b [c ~ d]] [e <f g>]" :: Pattern String)@@ -296,42 +289,40 @@ (cat ["1 1" :: Pattern Int, "2 [3 3] 4" :: Pattern Int, "3 [5 5] 7" :: Pattern Int]) describe "euclid" $ do- it "matches examples in Toussaint's paper" $ do- sequence_ $- map- (\(a, b) -> it b $ compareP (Arc 0 1) a (parseBP_E b))- ( [ (euclid 1 2 "x", "x ~"),- (euclid 1 3 "x", "x ~ ~"),- (euclid 1 4 "x", "x ~ ~ ~"),- (euclid 4 12 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~"),- (euclid 2 5 "x", "x ~ x ~ ~"),- -- (euclid 3 4 "x", "x ~ x x"), -- Toussaint is wrong..- (euclid 3 4 "x", "x x x ~"), -- correction- (euclid 3 5 "x", "x ~ x ~ x"),- (euclid 3 7 "x", "x ~ x ~ x ~ ~"),- (euclid 3 8 "x", "x ~ ~ x ~ ~ x ~"),- (euclid 4 7 "x", "x ~ x ~ x ~ x"),- (euclid 4 9 "x", "x ~ x ~ x ~ x ~ ~"),- (euclid 4 11 "x", "x ~ ~ x ~ ~ x ~ ~ x ~"),- -- (euclid 5 6 "x", "x ~ x x x x"), -- Toussaint is wrong..- (euclid 5 6 "x", "x x x x x ~"), -- correction- (euclid 5 7 "x", "x ~ x x ~ x x"),- (euclid 5 8 "x", "x ~ x x ~ x x ~"),- (euclid 5 9 "x", "x ~ x ~ x ~ x ~ x"),- (euclid 5 11 "x", "x ~ x ~ x ~ x ~ x ~ ~"),- (euclid 5 12 "x", "x ~ ~ x ~ x ~ ~ x ~ x ~"),- -- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~ ~"), -- Toussaint is wrong..- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~"), -- correction- -- (euclid 7 8 "x", "x ~ x x x x x x"), -- Toussaint is wrong..- (euclid 7 8 "x", "x x x x x x x ~"), -- Correction- (euclid 7 12 "x", "x ~ x x ~ x ~ x x ~ x ~"),- (euclid 7 16 "x", "x ~ ~ x ~ x ~ x ~ ~ x ~ x ~ x ~"),- (euclid 9 16 "x", "x ~ x x ~ x ~ x ~ x x ~ x ~ x ~"),- (euclid 11 24 "x", "x ~ ~ x ~ x ~ x ~ x ~ x ~ ~ x ~ x ~ x ~ x ~ x ~"),- (euclid 13 24 "x", "x ~ x x ~ x ~ x ~ x ~ x ~ x x ~ x ~ x ~ x ~ x ~")- ] ::- [(Pattern String, String)]- )+ describe "matches examples in Toussaint's paper" $ do+ mapM_ (\(a, b) -> it b $ compareP (Arc 0 1) a (parseBP_E b))+ ( [ (euclid 1 2 "x", "x ~"),+ (euclid 1 3 "x", "x ~ ~"),+ (euclid 1 4 "x", "x ~ ~ ~"),+ (euclid 4 12 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~"),+ (euclid 2 5 "x", "x ~ x ~ ~"),+ -- (euclid 3 4 "x", "x ~ x x"), -- Toussaint is wrong..+ (euclid 3 4 "x", "x x x ~"), -- correction+ (euclid 3 5 "x", "x ~ x ~ x"),+ (euclid 3 7 "x", "x ~ x ~ x ~ ~"),+ (euclid 3 8 "x", "x ~ ~ x ~ ~ x ~"),+ (euclid 4 7 "x", "x ~ x ~ x ~ x"),+ (euclid 4 9 "x", "x ~ x ~ x ~ x ~ ~"),+ (euclid 4 11 "x", "x ~ ~ x ~ ~ x ~ ~ x ~"),+ -- (euclid 5 6 "x", "x ~ x x x x"), -- Toussaint is wrong..+ (euclid 5 6 "x", "x x x x x ~"), -- correction+ (euclid 5 7 "x", "x ~ x x ~ x x"),+ (euclid 5 8 "x", "x ~ x x ~ x x ~"),+ (euclid 5 9 "x", "x ~ x ~ x ~ x ~ x"),+ (euclid 5 11 "x", "x ~ x ~ x ~ x ~ x ~ ~"),+ (euclid 5 12 "x", "x ~ ~ x ~ x ~ ~ x ~ x ~"),+ -- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~ ~"), -- Toussaint is wrong..+ (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~"), -- correction+ -- (euclid 7 8 "x", "x ~ x x x x x x"), -- Toussaint is wrong..+ (euclid 7 8 "x", "x x x x x x x ~"), -- Correction+ (euclid 7 12 "x", "x ~ x x ~ x ~ x x ~ x ~"),+ (euclid 7 16 "x", "x ~ ~ x ~ x ~ x ~ ~ x ~ x ~ x ~"),+ (euclid 9 16 "x", "x ~ x x ~ x ~ x ~ x x ~ x ~ x ~"),+ (euclid 11 24 "x", "x ~ ~ x ~ x ~ x ~ x ~ x ~ ~ x ~ x ~ x ~ x ~ x ~"),+ (euclid 13 24 "x", "x ~ x x ~ x ~ x ~ x ~ x ~ x x ~ x ~ x ~ x ~ x ~")+ ] ::+ [(Pattern String, String)]+ ) it "can be called with a negative first value to give the inverse" $ do compareP (Arc 0 1)
test/Sound/Tidal/UtilsTest.hs view
@@ -3,52 +3,51 @@ module Sound.Tidal.UtilsTest where import Sound.Tidal.Utils-import Test.Microspec+import Test.Hspec import Prelude hiding ((*>), (<*)) -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Utils" $ do- describe "delta" $ do- it "subtracts the second element of a tuple from the first" $ do- property $ delta (3, 10) === (7 :: Int)+ it "subtracts the second element of a tuple from the first" $ do+ delta (3, 10) `shouldBe` (7 :: Int) - describe "applies function to both elements of tuple" $ do- let res = mapBoth (+ 1) (2, 5)- property $ ((3, 6) :: (Int, Int)) === res+ it "applies function to both elements of tuple" $ do+ let res = mapBoth (+ 1) (2, 5)+ res `shouldBe` ((3, 6) :: (Int, Int)) - describe "apply function to first element of tuple" $ do- let res = mapFst (+ 1) (2, 5)- property $ ((3, 5) :: (Int, Int)) === res+ it "apply function to first element of tuple" $ do+ let res = mapFst (+ 1) (2, 5)+ res `shouldBe` ((3, 5) :: (Int, Int)) - describe "apply function to second element of tuple" $ do- let res = mapSnd (+ 1) (2, 5)- property $ ((2, 6) :: (Int, Int)) === res+ it "apply function to second element of tuple" $ do+ let res = mapSnd (+ 1) (2, 5)+ res `shouldBe` ((2, 6) :: (Int, Int)) - describe "return midpoint between first and second tuple value" $ do- let res = mid (2, 5)- property $ (3.5 :: Double) === res+ it "return midpoint between first and second tuple value" $ do+ let res = mid (2, 5)+ res `shouldBe` (3.5 :: Double) - describe "return of two lists, with unique values to each list" $ do- let res = removeCommon [1, 2, 5, 7, 12, 16] [2, 3, 4, 5, 15, 16]- property $ (([1, 7, 12], [3, 4, 15]) :: ([Int], [Int])) === res+ it "return of two lists, with unique values to each list" $ do+ let res = removeCommon [1, 2, 5, 7, 12, 16] [2, 3, 4, 5, 15, 16]+ res `shouldBe` (([1, 7, 12], [3, 4, 15]) :: ([Int], [Int])) - describe "wrap around indexing" $ do- let res = (!!!) [1 .. 5] 7- property $ (3 :: Int) === res+ it "wrap around indexing" $ do+ let res = (!!!) [1 .. 5] 7+ res `shouldBe` (3 :: Int) - describe "safe list indexing" $ do- let res = nth 2 ([] :: [Int])- property $ Nothing === res+ it "safe list indexing" $ do+ let res = nth 2 ([] :: [Int])+ res `shouldBe` Nothing - describe "list accumulation with given list elements" $ do- let res = accumulate ([1 .. 5] :: [Int])- property $ [1, 3, 6, 10, 15] === res+ it "list accumulation with given list elements" $ do+ let res = accumulate ([1 .. 5] :: [Int])+ res `shouldBe` [1, 3, 6, 10, 15] - describe "index elements in list" $ do- let res = enumerate ['a', 'b', 'c']- property $ [(0, 'a'), (1, 'b'), (2, 'c')] === res+ it "index elements in list" $ do+ let res = enumerate ['a', 'b', 'c']+ res `shouldBe` [(0, 'a'), (1, 'b'), (2, 'c')] - describe "split list by given pred" $ do- let res = wordsBy (== ':') "bd:3"- property $ ["bd", "3"] === res+ it "split list by given pred" $ do+ let res = wordsBy (== ':') "bd:3"+ res `shouldBe` ["bd", "3"]
test/Test.hs view
@@ -11,10 +11,10 @@ import Sound.Tidal.StepwiseTest import Sound.Tidal.UITest import Sound.Tidal.UtilsTest-import Test.Microspec+import Test.Hspec main :: IO ()-main = microspec $ do+main = hspec $ do Sound.Tidal.CoreTest.run Sound.Tidal.ParseTest.run Sound.Tidal.ParamsTest.run
test/TestUtils.hs view
@@ -1,34 +1,38 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE InstanceSigs #-} module TestUtils where import Data.List (sort) import qualified Data.Map.Strict as Map-import Data.Ratio as C-import Sound.Tidal.Control as C-import Sound.Tidal.Core as C-import Sound.Tidal.Params as C-import Sound.Tidal.ParseBP as C-import Sound.Tidal.Pattern as C-import Sound.Tidal.Scales as C-import Sound.Tidal.Show as C-import Sound.Tidal.Simple as C-import Sound.Tidal.Stepwise as C-import Sound.Tidal.UI as C-import Prelude hiding ((*>), (<*))--import Test.Microspec+import Sound.Tidal.ParseBP (parseBP_E)+import Sound.Tidal.Pattern+ ( Arc,+ ArcF (Arc),+ Context (Context),+ ControlPattern,+ Event,+ EventF (Event, value),+ Pattern,+ Value (VF, VI, VR, VS),+ ValueMap,+ defragParts,+ queryArc,+ setContext,+ )+import Sound.Tidal.Show ()+import Test.Hspec (Expectation, shouldBe) import Prelude hiding ((*>), (<*)) class TolerantEq a where (~==) :: a -> a -> Bool instance TolerantEq Double where+ (~==) :: Double -> Double -> Bool a ~== b = abs (a - b) < 0.000001 instance TolerantEq Value where+ (~==) :: Value -> Value -> Bool (VS a) ~== (VS b) = a == b (VI a) ~== (VI b) = a == b (VR a) ~== (VR b) = a == b@@ -36,22 +40,25 @@ _ ~== _ = False instance (TolerantEq a) => TolerantEq [a] where+ (~==) :: (TolerantEq a) => [a] -> [a] -> Bool as ~== bs = (length as == length bs) && all (uncurry (~==)) (zip as bs) instance TolerantEq ValueMap where+ (~==) :: ValueMap -> ValueMap -> Bool a ~== b = Map.differenceWith (\a' b' -> if a' ~== b' then Nothing else Just a') a b == Map.empty instance TolerantEq (Event ValueMap) where+ (~==) :: Event ValueMap -> Event ValueMap -> Bool (Event _ w p x) ~== (Event _ w' p' x') = w == w' && p == p' && x ~== x' -- | Compare the events of two patterns using the given arc-compareP :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property+compareP :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Expectation compareP a p p' = sort (queryArc (stripContext p) a) `shouldBe` sort (queryArc (stripContext p') a) -- | Like @compareP@, but tries to 'defragment' the events-comparePD :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property+comparePD :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Expectation comparePD a p p' = sort (defragParts $ queryArc (stripContext p) a) `shouldBe` sort (defragParts $ queryArc (stripContext p') a)
tidal-core.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 name: tidal-core-version: 1.9.6+version: 1.10.0 license: GPL-3 copyright: (c) Alex McLean and other contributors, 2025@@ -45,7 +45,7 @@ build-depends: base >=4.8 && <5,- containers <0.8,+ containers <0.9, colour <2.4, text <2.2, parsec >=3.1.12 && <3.2,@@ -74,7 +74,7 @@ build-depends: base >=4 && <5,- microspec >=0.2.0.1,+ hspec >=2.11.9, containers, tidal-core, deepseq