Skip to content

Commit

Permalink
etc
Browse files Browse the repository at this point in the history
  • Loading branch information
@ejconlon
ejconlon committed Dec 30, 2024
1 parent 8af1a50 commit 0648582
Show file tree
Hide file tree
Showing 2 changed files with 92 additions and 96 deletions.
42 changes: 19 additions & 23 deletions minipat/src/Minipat/Quant.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
146 changes: 73 additions & 73 deletions minipat/test/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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, (===))
Expand Down Expand Up @@ -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" $
Expand Down Expand Up @@ -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
Expand All @@ -1010,5 +1010,5 @@ main = do
, testPatReprCases
, testUr
, testQuant
-- , testTrig
, testQuantStep
]

0 comments on commit 0648582

Please sign in to comment.