diff --git a/minipat/src/Minipat/Quant.hs b/minipat/src/Minipat/Quant.hs index d36d8ff..83493ab 100644 --- a/minipat/src/Minipat/Quant.hs +++ b/minipat/src/Minipat/Quant.hs @@ -31,20 +31,20 @@ type ArcStrat = Arc TimeStrat type StepFun = Integer -> CycleDelta -> StepDelta -type OriginFun = CycleTime -> CycleTime +type OutputFun a = CycleTime -> StepTime -> a -type OutputFun a = CycleTime -> CycleDelta -> StepTime -> StepDelta -> a - -type AdjustFun a b c = OriginFun -> OutputFun a -> Integer -> b -> c +type AdjustFun a b c = OutputFun a -> Integer -> b -> c adjustTime :: StepFun -> AdjustFun a CycleTime a -adjustTime stepFun originFun outFun steps time = - let cycOrigin = originFun time - stepOrigin = floor (cycOrigin * fromInteger steps) - cycDelta = measure cycOrigin time +adjustTime stepFun outFun steps time = + let cycOrigin = floor time + stepOrigin = cycOrigin * steps + cycDelta = measure (fromInteger cycOrigin) time stepDelta = stepFun steps cycDelta - newCycDelta = CycleDelta (unStepDelta stepDelta % steps) - in outFun cycOrigin newCycDelta stepOrigin stepDelta + outCycDelta = CycleDelta (unStepDelta stepDelta % steps) + outCycTime = shift outCycDelta (fromInteger cycOrigin) + outStepTime = shift stepDelta (fromInteger stepOrigin) + in outFun outCycTime outStepTime primStepFun :: (Rational -> Integer) -> StepFun primStepFun f steps = StepDelta . f . (fromInteger steps *) . unCycleDelta @@ -60,35 +60,31 @@ quantTime :: TimeStrat -> AdjustFun a CycleTime a quantTime = adjustTime . stratStepFun quantArc :: ArcStrat -> AdjustFun a (Arc CycleTime) (Arc a) -quantArc (Arc startStrat endStrat) originFun outFun steps (Arc startTime endTime) = - let f strat = quantTime strat originFun outFun steps +quantArc (Arc startStrat endStrat) outFun steps (Arc startTime endTime) = + let f strat = quantTime strat outFun steps in Arc (f startStrat startTime) (f endStrat endTime) quantSpan :: ArcStrat -> AdjustFun a (Span CycleTime) (Span a) -quantSpan strat originFun outFun steps (Span ac mwh) = - let f = quantArc strat originFun outFun steps +quantSpan strat outFun steps (Span ac mwh) = + let f = quantArc strat outFun steps in Span (f ac) (fmap f mwh) -quantOrigin :: OriginFun -quantOrigin = CycleTime . fromInteger . floor . unCycleTime - quantCycOut :: OutputFun CycleTime -quantCycOut o d _ _ = shift d o +quantCycOut x _ = x quantStepOut :: OutputFun StepTime -quantStepOut _ _ o d = shift d o +quantStepOut _ y = y -- | Quantize the pattern into the given number of steps per cycle by -- nudging event start and end times to align with step times. quant :: (Flow f) => ArcStrat -> Integer -> f a -> f a -quant strat = flowNudge . quantArc strat quantOrigin quantCycOut +quant strat = flowNudge . quantArc strat quantCycOut -- | Quantize the stream and emit a tape of events over the given time range. quantStep :: ArcStrat -> Integer -> Stream a -> Arc StepTime -> Tape StepTime a quantStep strat steps stream stepArc = stepTape where - stepLen = CycleTime (1 % steps) - cycArc = fmap ((stepLen *) . fromIntegral) stepArc + cycArc = fmap (CycleTime . (% steps) . unStepTime) stepArc cycTape = streamRun stream cycArc - onSpan = quantSpan strat quantOrigin quantStepOut steps + onSpan = quantSpan strat quantStepOut steps stepTape = T.tapeConcatMap (\(Ev sp a) -> T.tapeSingleton (Ev (onSpan sp) a)) cycTape diff --git a/minipat/test/Main.hs b/minipat/test/Main.hs index 5e851b3..ff6862d 100644 --- a/minipat/test/Main.hs +++ b/minipat/test/Main.hs @@ -26,10 +26,10 @@ import Minipat.Interp (interpPat) import Minipat.Norm (normPat) import Minipat.Parser (Loc, P, ParseErr, factorP, identP, identPatP, selectIdentPatP) import Minipat.Print (prettyShow) -import Minipat.Quant (ArcStrat, TimeStrat (..), quant) +import Minipat.Quant (ArcStrat, TimeStrat (..), quant, quantStep) import Minipat.Stream (Stream, streamRun, streamSeq) import Minipat.Tape (Ev (..), tapeToList) -import Minipat.Time (Arc (..), CycleArc, CycleTime (..), Span (..)) +import Minipat.Time (Arc (..), CycleArc, CycleTime (..), Span (..), StepArc, StepTime (..)) import Minipat.Ur (ur) import Prettyprinter qualified as P import PropUnit (MonadTest, TestName, TestTree, assert, testGroup, testUnit, (===)) @@ -427,6 +427,11 @@ ev start end val = let arc = Arc (CycleTime start) (CycleTime end) in Ev (Span arc (Just arc)) val +evStep :: Integer -> Integer -> x -> Ev StepTime x +evStep start end val = + let arc = Arc (StepTime start) (StepTime end) + in Ev (Span arc (Just arc)) val + testPatInterpCases :: TestTree testPatInterpCases = testGroup "pat interp cases" $ @@ -927,76 +932,71 @@ testQuant = ) ] --- runTrigCase --- :: (TestName, Maybe CycleArc, ArcStrat, Integer, Stream Ident, [Ev CycleTime (Anno Trig Ident)]) --- -> TestTree --- runTrigCase (n, mayArc, strat, steps, str, evs) = --- runStreamCase (n, mayArc, quantTrig strat steps str, evs) --- --- testTrig :: TestTree --- testTrig = --- let strat = Arc TimeStratRound TimeStratRound --- steps = 4 --- seqStr2 = streamSeq (fmap pure ["a", "b"]) --- seqStr3 = streamSeq (fmap pure ["a", "b", "c"]) --- seqStr4 = streamSeq (fmap pure ["a", "b", "c", "d"]) --- trigOn = Anno (Trig True False) --- trigOff = Anno (Trig False True) --- trigOnOff = Anno (Trig True True) --- in testGroup "quant" $ --- fmap --- runTrigCase --- [ --- ( "trig 1" --- , Nothing --- , strat --- , steps --- , pure "a" --- , --- [ ev 0 (1 % 4) (trigOn "a") --- , ev (3 % 4) 1 (trigOff "a") --- ] --- ) --- , --- ( "trig 2" --- , Nothing --- , strat --- , steps --- , seqStr2 --- , --- [ ev 0 (1 % 4) (trigOn "a") --- , ev (1 % 4) (1 % 2) (trigOff "a") --- , ev (1 % 2) (3 % 4) (trigOn "b") --- , ev (3 % 4) 1 (trigOff "b") --- ] --- ) --- , --- ( "trig 3" --- , Nothing --- , strat --- , steps --- , seqStr3 --- , --- [ ev 0 (1 % 4) (trigOnOff "a") --- , ev (1 % 4) (1 % 2) (trigOn "b") --- , ev (1 % 2) (3 % 4) (trigOff "b") --- , ev (3 % 4) 1 (trigOnOff "c") --- ] --- ) --- , --- ( "trig 4" --- , Nothing --- , strat --- , steps --- , seqStr4 --- , --- [ ev 0 (1 % 4) (trigOnOff "a") --- , ev (1 % 4) (1 % 2) (trigOnOff "b") --- , ev (1 % 2) (3 % 4) (trigOnOff "c") --- , ev (3 % 4) 1 (trigOnOff "d") --- ] --- ) --- ] +runQuantStepCase + :: (TestName, Maybe StepArc, ArcStrat, Integer, Stream Ident, [Ev StepTime Ident]) + -> TestTree +runQuantStepCase (n, mayArc, strat, steps, str, evs) = testUnit n $ do + let arc = fromMaybe (Arc 0 (fromInteger steps)) mayArc + actualEvs = tapeToList (quantStep strat steps str arc) + actualEvs === evs + +testQuantStep :: TestTree +testQuantStep = + let strat = Arc TimeStratRound TimeStratRound + steps = 4 + seqStr2 = streamSeq (fmap pure ["a", "b"]) + seqStr3 = streamSeq (fmap pure ["a", "b", "c"]) + seqStr4 = streamSeq (fmap pure ["a", "b", "c", "d"]) + in testGroup "quant step" $ + fmap + runQuantStepCase + [ + ( "trig 1" + , Nothing + , strat + , steps + , pure "a" + , + [ evStep 0 4 "a" + ] + ) + , + ( "trig 2" + , Nothing + , strat + , steps + , seqStr2 + , + [ evStep 0 2 "a" + , evStep 2 4 "b" + ] + ) + , + ( "trig 3" + , Nothing + , strat + , steps + , seqStr3 + , + [ evStep 0 1 "a" + , evStep 1 3 "b" + , evStep 3 4 "c" + ] + ) + , + ( "trig 4" + , Nothing + , strat + , steps + , seqStr4 + , + [ evStep 0 1 "a" + , evStep 1 2 "b" + , evStep 2 3 "c" + , evStep 3 4 "d" + ] + ) + ] main :: IO () main = do @@ -1010,5 +1010,5 @@ main = do , testPatReprCases , testUr , testQuant - -- , testTrig + , testQuantStep ]