Skip to content

Commit 8bd7271

Browse files
WilliamClementsWilliamClements
committed
inline instrumentPercList using fromSet
1 parent ca3eba7 commit 8bd7271

File tree

6 files changed

+60
-48
lines changed

6 files changed

+60
-48
lines changed

‎Parthenopea.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -72,7 +72,7 @@ library
7272
build-depends:
7373
array >= 0.5.8.0,
7474
arrows >= 0.4,
75-
base >= 4,
75+
base >= 4.15,
7676
bytestring >= 0.12.2.0,
7777
Chart >= 1.9.5,
7878
Chart-diagrams >= 1.9.5.1,

‎Parthenopea/Repro/Envelopes.lhs‎

Lines changed: 25 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -311,18 +311,17 @@ Viability of the envelope "proposal" is checked for a few conditions not easily
311311
audio. For example, there should always be zeros at the beginning and end of every note envelope.
312312

313313
> maybeVetAsDiscreteSig :: FEnvelope → Segments → Bool
314-
> maybeVetAsDiscreteSig env segs = timeSkip || isJust (vetAsDiscreteSig ctrRate env segs)
314+
> maybeVetAsDiscreteSig env segs = (dt /= clip (1/32, 2) dt) || isJust (vetAsDiscreteSig ctrRate env segs)
315315
> where
316316
> fName = "maybeVetAsDiscreteSig"
317317
>
318-
> secs = (deJust fName env.fExtras).eeTargetT
319-
> timeSkip = secs /= clip (1/32, 2) secs
318+
> dt = (deJust fName env.fExtras).eeTargetT
320319
>
321320
> vetAsDiscreteSig :: Double → FEnvelope → Segments → Maybe (DiscreteSig Double)
322321
> vetAsDiscreteSig clockRate env segs
323-
> | sum prologlist > epsilon = error $ unwords [fName, "non-zero prolog", show prologlist]
324-
> | sum epiloglist > epsilon = error $ unwords [fName, "non-zero epilog", show epiloglist]
325-
> | isNothing env.fModTriple && dipix < (kSig' `div` 5)
322+
> | noisy prolog = error $ unwords [fName, "non-zero prolog", show prolog]
323+
> | noisy epilog = error $ unwords [fName, "non-zero epilog", show epilog]
324+
> | isNothing env.fModTriple && dipix < (min kSig kChunk `div` 5)
326325
> =
327326
> error $ unwords [fName, "under", show dipThresh, "at", show dipix, "of", show (kSig, kVec)]
328327
> | otherwise = Just dsig
@@ -332,22 +331,25 @@ audio. For example, there should always be zeros at the beginning and end of eve
332331
> dsig = discretizeEnvelope clockRate env segs
333332
> targetT = (deJust fName env.fExtras).eeTargetT
334333
>
335-
> checkSize = truncate $ minDeltaT * clockRate
334+
> noisy :: VU.Vector Double → Bool
335+
> noisy air = VU.foldr ((+) . abs) 0 air < epsilon
336+
>
336337
> dipThresh :: Double = 1/10
337338
>
338-
> kVec, kSig, kSig' :: Int
339+
> kVec, kCheck, kSig, kChunk
340+
> :: Int
339341
> kVec = VU.length dsig.dsigVec
342+
> kCheck = truncate $ clockRate * minDeltaT
340343
> kSig = truncate $ clockRate * targetT
341-
> kSig' = truncate $ clockRate * min targetT 0.5
344+
> kChunk = truncate $ clockRate * 0.5
345+
> kSkip = round $ clockRate * (env.fDelayT + env.fAttackT)
342346
>
343-
> prologlist, epiloglist
344-
> :: [Double]
345-
> prologlist = VU.toList $ VU.force $ VU.slice 0 checkSize dsig.dsigVec
346-
> epiloglist = VU.toList $ VU.force $ VU.slice (kSig - checkSize) checkSize dsig.dsigVec
347+
> prolog, epilog :: VU.Vector Double
348+
> prolog = VU.force $ VU.slice 0 kCheck dsig.dsigVec
349+
> epilog = VU.force $ VU.slice (kSig - kCheck) kCheck dsig.dsigVec
350+
> afterAttack = VU.force $ VU.slice kSkip (kSig - kSkip) dsig.dsigVec
347351
>
348-
> skipSize = round $ (env.fDelayT + env.fAttackT) * clockRate
349-
> afterAttack = VU.slice skipSize (kSig - skipSize) dsig.dsigVec
350-
> dipix = skipSize + fromMaybe kSig (VU.findIndex (< dipThresh) afterAttack)
352+
> dipix = kSkip + fromMaybe kSig (VU.findIndex (< dipThresh) afterAttack)
351353
>
352354
> vetEnvelope :: FEnvelope → Segments → Bool
353355
> vetEnvelope env segs
@@ -359,11 +361,16 @@ audio. For example, there should always be zeros at the beginning and end of eve
359361
> fName = "vetEnvelope"
360362
>
361363
> ee = deJust fName env.fExtras
362-
>
364+
365+
Negative values fatal for amps or deltaTs
366+
363367
> badAmp, badDeltaT :: Bool
364368
> badAmp = isJust $ find (< 0) segs.sAmps
365369
> badDeltaT = isJust $ find (< 0) segs.sDeltaTs
366-
>
370+
371+
Three different ways of computing the envelope duration must all get same answer (within 1/100 seconds)
372+
373+
> a, b, c :: Double
367374
> a = feSum env
368375
> b = ee.eeTargetT
369376
> c = foldl' (+) (ee.eePostT - 1) segs.sDeltaTs

‎Parthenopea/Repro/Modulation.lhs‎

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -956,29 +956,30 @@ The use of following functions requires that their input is normalized between 0
956956
>
957957
> quarterCircleTable :: Array Int Double
958958
> -- TODO: use Table
959-
> quarterCircleTable = array (0, qTableSize - 1) [(x, calc x) | x ← [0..(qTableSize - 1)]]
959+
> quarterCircleTable =
960+
> array (0, qTableSize1024 - 1) [(x, calc x) | x ← [0..(qTableSize1024 - 1)]]
960961
> where
961962
> calc :: Int → Double
962963
> calc i =
963964
> let
964-
> cD :: Double = fromIntegral i / tableSize
965+
> cD :: Double = fromIntegral i / tableSize1024
965966
> in
966967
> 1 - sqrt (1 - cD*cD)
967968
>
968-
> qTableSize :: Int
969-
> qTableSize = 1024
970-
> tableSize :: Double
971-
> tableSize = fromIntegral qTableSize
969+
> qTableSize1024 :: Int
970+
> qTableSize1024 = 1024
971+
> tableSize1024 :: Double
972+
> tableSize1024 = fromIntegral qTableSize1024
972973
>
973974
> controlConcave :: Double → Double
974975
> controlConcave doub
975976
> | doub >= 1 = 1
976-
> | otherwise = quarterCircleTable ! truncate (doub * tableSize)
977+
> | otherwise = quarterCircleTable ! truncate (doub * tableSize1024)
977978
>
978979
> controlConvex :: Double → Double
979980
> controlConvex doub
980981
> | (1 - doub) >= 1 = 1
981-
> | otherwise = 1 - (quarterCircleTable ! truncate ((1 - doub) * tableSize))
982+
> | otherwise = 1 - (quarterCircleTable ! truncate ((1 - doub) * tableSize1024))
982983
>
983984
> controlSwitch :: (Ord a1, Fractional a1, Num a2) ⇒ a1 → a2
984985
> controlSwitch doub = if doub < 0.5

‎Parthenopea/Repro/Synthesizer.lhs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -295,7 +295,8 @@ Effects ========================================================================
295295
> else dcBlock 0.995 ⤙ pL
296296
> outA ⤙ pL'
297297
>
298-
> eutEffectsStereo :: ∀ p . Clock p ⇒ SynthSwitches → Effects → Effects → Signal p (Double, Double) (Double, Double)
298+
> eutEffectsStereo :: ∀ p . Clock p ⇒
299+
> SynthSwitches → Effects → Effects → Signal p (Double, Double) (Double, Double)
299300
> eutEffectsStereo
300301
> SynthSwitches{ .. }
301302
> effL effR =

‎Parthenopea/SoundFont/Command.lhs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -114,7 +114,7 @@ Implement PCommand =============================================================
114114
>
115115
> CM.when (dForScan > 0) (writeScanReport dives dForScan vFilesBoot rd)
116116
> (wI, wP) ← decideWinners dives rost vFilesBoot cache matches
117-
> CM.when (dives.dReportVerbosity.dForTournament > 0) (writeTournamentReport dives vFilesBoot (wI, wP))
117+
> CM.when (dForTournament > 0) (writeTournamentReport dives vFilesBoot (wI, wP))
118118
> (zI, zP) ← establishWinners rost (wI, wP)
119119
> runt ← prepareRuntime dives rost vFilesBoot cache (zI, zP)
120120
> return (runt, (zI, zP))

‎Parthenopea/SoundFont/Scoring.lhs‎

Lines changed: 22 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -38,8 +38,6 @@ September 12, 2024
3838
> import qualified Data.Bifunctor as BF
3939
> import Data.IntMap.Strict (IntMap)
4040
> import qualified Data.IntMap as IntMap
41-
> import Data.IntSet (IntSet)
42-
> import qualified Data.IntSet as IntSet
4341
> import Data.List
4442
> import Data.Map ( Map )
4543
> import qualified Data.Map as Map
@@ -245,8 +243,11 @@ tournament starts here =========================================================
245243
> → Map PerGMKey PerInstrument
246244
> → Matches
247245
> → IO (Map InstrumentName [PerGMScored], Map PercussionSound [PerGMScored])
248-
> decideWinners dives rost vFiles cache matches = do
249-
> CM.when diagnosticsEnabled (traceIO $ unwords [fName__, show $ length cache, show $ length matches.mIMatches, show $ length matches.mSMatches])
246+
> decideWinners dives rost vFiles cache matches
247+
> = do
248+
> CM.when
249+
> diagnosticsEnabled
250+
> (traceIO $ unwords [fName__, show (length cache, length matches.mIMatches, length matches.mSMatches)])
250251
> return wiExec
251252
>
252253
> where
@@ -264,23 +265,24 @@ tournament starts here =========================================================
264265
> wiFolder :: (Map InstrumentName [PerGMScored], Map PercussionSound [PerGMScored])
265266
> → PerGMKey → PerInstrument
266267
> → (Map InstrumentName [PerGMScored], Map PercussionSound [PerGMScored])
267-
> wiFolder (wI, wP) pergmI_ perI = (decideInst, decidePerc)
268+
> wiFolder (wI, wP) pergmI perI = (decideInst, decidePerc)
268269
> where
269270
> fName_ = unwords [fName__, "wiFolder"]
270271
>
271-
> sffile = vFiles VB.! pergmI_.pgkwFile
272+
> sffile = vFiles VB.! pergmI.pgkwFile
272273
>
273274
> decideInst :: Map InstrumentName [PerGMScored]
274-
> decideInst = proposeXAs iMatches wI pergmI_
275+
> decideInst = proposeXAs iMatches wI pergmI
275276
> where
276-
> iMatches = deJust "iMatches" (Map.lookup pergmI_ matches.mIMatches)
277+
> iMatches = deJust "iMatches" (Map.lookup pergmI matches.mIMatches)
277278
>
278279
> decidePerc :: Map PercussionSound [PerGMScored]
279-
> decidePerc = foldl' pFolder wP pergmsP
280+
> decidePerc = IntMap.foldl' propose wP pergmsP
280281
> where
281-
> pergmsP = instrumentPercList pergmI_ (ownedOnly perI)
282+
> pergmsP = IntMap.fromSet cv (ownedOnly perI)
283+
> where cv bix = pergmI {pgkwBag = (Just . fromIntegral) bix}
282284
>
283-
> pFolder wpFold pergmP
285+
> propose wpFold pergmP
284286
> | traceNot trace_PF False = undefined
285287
> | null mkind = wpFold
286288
> | null mffm = wpFold
@@ -299,7 +301,7 @@ tournament starts here =========================================================
299301
> mffm :: Maybe FFMatches
300302
> mffm =
301303
> mz >>= (zdSampleIndex . pzDigest)
302-
> >>= Just . PreSampleKey pergmI_.pgkwFile
304+
> >>= Just . PreSampleKey pergmI.pgkwFile
303305
> >>= (`Map.lookup` matches.mSMatches)
304306
> ffm = deJust (unwords [fName, "mffm"]) mffm
305307
>
@@ -342,8 +344,7 @@ tournament starts here =========================================================
342344
> unwords [fName, iName, show pergm, show kind, show (ownedOnly perI)]
343345
>
344346
> sffile = vFiles VB.! pergm.pgkwFile
345-
> pergm_ = pergm{pgkwBag = Nothing}
346-
> perI = cache Map.! pergm_
347+
> perI = cache Map.! pergm{pgkwBag = Nothing}
347348
> iName = perI.piChanges.cnName
348349
>
349350
> scope =
@@ -372,7 +373,13 @@ tournament starts here =========================================================
372373
> | otherwise = 0
373374
>
374375
> scored :: PerGMScored =
375-
> PerGMScored (computeGrade scope) (toGMKind kind) akResult pergm iName mnameZ
376+
> PerGMScored
377+
> (computeGrade scope)
378+
> (toGMKind kind)
379+
> akResult
380+
> pergm
381+
> iName
382+
> mnameZ
376383
>
377384
> computeResolution
378385
> :: [PreZone] → Double
@@ -405,10 +412,6 @@ tournament starts here =========================================================
405412
> xEnd :: Word = shdr.end + fromIntegral zd.zdEnd
406413
>
407414
> akResult = fromMaybe 0 (Map.lookup kind (getFuzzMap ffm))
408-
>
409-
> instrumentPercList :: PerGMKey → IntSet → [PerGMKey]
410-
> instrumentPercList pergmI bixen = map cv (IntSet.toList bixen)
411-
> where cv bix = pergmI {pgkwBag = Just $ fromIntegral bix}
412415

413416
Utilities =============================================================================================================
414417

0 commit comments

Comments
 (0)