Skip to content

Commit 69ad0dc

Browse files
WilliamClementsWilliamClements
committed
introduce fwDirty
1 parent 3dd3952 commit 69ad0dc

File tree

3 files changed

+84
-84
lines changed

3 files changed

+84
-84
lines changed

‎Parthenopea/Repro/Envelopes.lhs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -117,7 +117,7 @@ Create a straight-line envelope generator with following phases:
117117
> 2 → segmentsFor2
118118
> 4 → segmentsFor4
119119
> _ →
120-
> error $ unwords [fName, show dLen, "is illegal length for velo sweeping sweeps"]
120+
> error $ unwords [fName, show dLen, "is illegal (not two or four) length for velo sweeping"]
121121
>
122122
> stVelo0, enVelo0, stVelo1, enVelo1, step, midsection, leg
123123
> :: Double

‎Parthenopea/Repro/Synthesizer.lhs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -61,8 +61,8 @@ Euterpea provides call back mechanism for rendering. Each Midi note, fully speci
6161
> (m8nL, m8nR) = (reconL.rM8n, reconR.rM8n)
6262
>
6363
> numPoints :: Double = fromIntegral (reconL.rApplied.rEnd - reconL.rApplied.rStart)
64-
> secsSampled = numPoints * freqRatio / sr
65-
> secsScored = 1 * fromRational dur
64+
> secsSampled :: Double = numPoints * freqRatio / sr
65+
> secsScored :: Double = 1 * fromRational dur
6666
> looping :: Bool = secsScored > secsSampled
6767
> && (reconL.rSampleMode /= A.NoLoop)
6868
> && useLoopSwitching

‎Parthenopea/SoundFont/Boot.lhs‎

Lines changed: 81 additions & 81 deletions
Original file line numberDiff line numberDiff line change
@@ -45,10 +45,16 @@ Each stage interface function takes FileWork and returns modified FileWork.
4545
(1) reorg stage depends on previously computed smashups, but then recreates absorption leaders' smashups to reflect
4646
the new zonage.
4747

48-
(2) Fast to modify smashups when incrementally adding zones. But to REMOVE a zone means expensively recomputing
49-
smashup across all remaining zones.
48+
(2) Fast to modify smashups when incrementally adding zones. But to REMOVE a zone means expensively recomputing.
5049

51-
(3) How does _crossInstrumentPairing_ interact with _doAbsorption_?
50+
(3) two resources in jeopardy - zone owners and instrument smashups
51+
a. reorg goes ahead and patches up both
52+
b. vet patches up owners map explicitly
53+
c. what makes the smashups go wonky?
54+
1. deleting zones at pair → vet
55+
2. adding the cross instrument pairings
56+
57+
(4) How does _crossInstrumentPairing_ interact with _doAbsorption_?
5258
a...If both True, a valid cross instrument pairing can still work even if absorption didn't fix it
5359
b...If both False, easy, just don't do either
5460
c...If cross True, absorption False, cross pairing only accomplished explicitly (honoring well-formed crossings)
@@ -112,16 +118,17 @@ FileWork =======================================================================
112118
> data FileWork =
113119
> FileWork {
114120
> _fwDirectives :: Directives
115-
> , _fwZRecs :: IntMap InstZoneRecord {- [InstIndex → zrec] -}
116-
> , _fwPreZones :: IntMap PreZone {- [BagIndex → pz] -}
121+
> , _fwZRecs :: IntMap InstZoneRecord {- [InstIndex → zrec] -}
122+
> , _fwPreZones :: IntMap PreZone {- [BagIndex → pz] -}
117123
>
118-
> , _fwZoneOwners :: IntMap IntSet {- [InstIndex → [BagIndex]] -}
119-
> , _fwZonePartners :: IntMap IntSet {- [InstIndex → [BagIndex]] -}
124+
> , _fwZoneOwners :: IntMap IntSet {- [InstIndex → [BagIndex]] -}
125+
> , _fwZonePartners :: IntMap IntSet {- [InstIndex → [BagIndex]] -}
120126
>
121127
> , _fwPreSamples :: Map PreSampleKey PreSample
122128
> , _fwPerInstruments :: Map PerGMKey PerInstrument
123129
> , _fwMatches :: Matches
124130
> , _fwPairing :: Pairing
131+
> , _fwDirty :: IntSet {- [InstIndex] -}
125132
> , _fwDispositions :: ResultDispositions}
126133
> defFileWork :: Directives → FileWork
127134
> defFileWork dives =
@@ -135,6 +142,7 @@ FileWork =======================================================================
135142
> Map.empty
136143
> defMatches
137144
> defPairing
145+
> IntSet.empty
138146
> virginrd
139147
> makeLenses ''FileWork
140148
>
@@ -164,16 +172,12 @@ FileWork =======================================================================
164172
> show fi =
165173
> unwords ["FileIterate", show fi.fiFw]
166174
> reduceFileIterate :: FileIterate → Survey
167-
> reduceFileIterate FileIterate{ .. }
168-
> =
175+
> reduceFileIterate fi =
169176
> Survey
170-
> _fwPreZones
171-
> _fwPerInstruments
172-
> _fwMatches
173-
> _fwDispositions
174-
> where
175-
> FileWork{ .. }
176-
> = fiFw
177+
> (fi.fiFw ^. fwPreZones)
178+
> (fi.fiFw ^. fwPerInstruments)
179+
> (fi.fiFw ^. fwMatches)
180+
> (fi.fiFw ^. fwDispositions)
177181

178182
(Mostly ignoring dispo contribution as it is unproblematic)
179183

@@ -190,19 +194,20 @@ Task reorg invalidates Owners Map by what it does
190194
repairs owners map afterward
191195
Task match (modifies fuzzy data only)
192196
Task pair
193-
develops Pairing
194197
creates Action map, based on partners and PreZones
195198
does not modify PreZones
196-
Task vet modifies or deletes PreZones based on Action map
197-
Task shrink
198-
Task rat adjusts for exotic pairing ahead of smash 2 and perI
199+
adjusts for exotic pairing ahead of smash 2 and perI
200+
Task vet
201+
modifies or deletes PreZones based on Action map
202+
repairs owners map
203+
Task shrink carries out the smashup invalidations
199204
Task perI creates PerInstrument map based on Owners map and PreZone data
200205

201206
FileWork development
202207

203208
> preSampleTaskIf, smellTaskIf, instrumentTaskIf, captureTaskIf, pairTaskIf, vetTaskIf
204209
> , adoptTaskIf, smashTaskIf, reorgTaskIf, matchTaskIf, cleanTaskIf, perITaskIf
205-
> , shrinkTaskIf, ratTaskIf
210+
> , shrinkTaskIf
206211
> :: SFFileBoot → ([InstrumentName], [PercussionSound]) → FileWork → FileWork
207212
>
208213
> makeFileIterate :: Directives → SFFileBoot → ([InstrumentName], [PercussionSound]) → FileIterate
@@ -220,7 +225,6 @@ FileWork development
220225
> , ("pair", pair)
221226
> , ("vet", clean . vet)
222227
> , ("adopt", adopt)
223-
> , ("rat", rat)
224228
> , ("smash 2", smash . shrink)
225229
> , ("perI", perI)]
226230
> where
@@ -235,7 +239,6 @@ FileWork development
235239
> pair = pairTaskIf sffile rost
236240
> vet = vetTaskIf sffile rost
237241
> adopt = adoptTaskIf sffile rost
238-
> rat = ratTaskIf sffile rost
239242
> shrink = shrinkTaskIf sffile rost
240243
> perI = perITaskIf sffile rost
241244

@@ -326,10 +329,7 @@ pre-sample task ================================================================
326329
> Just SampleTypeRight → "stereo"
327330
> _ → "mono"
328331
>
329-
> sampleSizeOk :: Int → Int → Bool
330-
> sampleSizeOk stS enS = stS >= 0 && enS - stS >= 0 && enS - stS < 2 ^ (22::Int)
331-
>
332-
> goodSampleRate :: Int → Bool
332+
> sampleSizeOk stS enS = stS >= 0 && enS - stS >= 32 && enS - stS < 2 ^ (22::Int)
333333
> goodSampleRate x = x == clip (64, 2 ^ (20::Int)) x
334334
>
335335
> ssSample_
@@ -365,11 +365,11 @@ smell task =====================================================================
365365
> mback_ =
366366
> presk{pskwSampleIndex = fromIntegral siOut} `Map.lookup` (fWork ^. fwPreSamples)
367367
> mback = mback_ >>= backOk
368-
> where
369-
> backOk opres =
370-
> if isRightPS opres && fromIntegral (effPSShdr opres).sampleLink == siIn
371-
> then Just siOut
372-
> else Nothing
368+
>
369+
> backOk opres =
370+
> if isRightPS opres && fromIntegral (effPSShdr opres).sampleLink == siIn
371+
> then Just siOut
372+
> else Nothing
373373
> in
374374
> case mback of
375375
> Nothing → m
@@ -701,16 +701,16 @@ pair task ======================================================================
701701

702702
> pairTaskIf _ _ fWork =
703703
> ( (fwPairing . fwZonePairings .~ (sy ^. psPaired))
704-
> . (fwPairing . fwZoneModified .~ (makeActions fWork (sy ^. psUnpaired)))
705-
> . (fwDispositions .~ (sy ^. psDispos))) fWork
704+
> . (fwPairing . fwZoneModified .~ modified)
705+
> . (fwDispositions .~ (sy ^. psDispos))
706+
> . (fwDirty .~ dirty)
707+
> . (fwZonePartners .~ partners)) fWork
706708
> where
707709
> fName__ = "pairTaskIf"
708710
>
709711
> Directives{ .. }
710712
> = fWork ^. fwDirectives
711-
> Pairing{ .. }
712-
> = fWork ^. fwPairing
713-
713+
714714
pairing approach ======================================================================================================
715715
After somehow generating the pair list for this sffile, reject all other stereo zones - they failed to pair!
716716
The "somehow" is to make pairs if and only if L and R's zones produce identical "pair slots".
@@ -751,9 +751,9 @@ Pairing algorithm phases =======================================================
751751
Each of these three functions operates on unpaired set. They are invoked, in equence, during iterate'.
752752

753753
> nominal sy =
754-
> IntMap.foldlWithKey (conducePartners False (sy ^. psUnpaired)) IntMap.empty _fwSamplePairings
754+
> IntMap.foldlWithKey (conducePartners False (sy ^. psUnpaired)) IntMap.empty (fWork ^. fwPairing ^. fwSamplePairings)
755755
> exotic sy =
756-
> IntMap.foldlWithKey (conducePartners True (sy ^. psUnpaired)) IntMap.empty _fwSamplePairings
756+
> IntMap.foldlWithKey (conducePartners True (sy ^. psUnpaired)) IntMap.empty (fWork ^. fwPairing ^. fwSamplePairings)
757757
> linkless sy =
758758
> let
759759
> (bixenL, bixenR) = IntSet.partition isLeft (sy ^. psUnpaired)
@@ -833,6 +833,27 @@ Pairing algorithm phases =======================================================
833833
> areParallel bixL bixR = (accessPreZone "pin bixL" (fWork ^. fwPreZones) bixL).pzWordI
834834
> == (accessPreZone "pin bixR" (fWork ^. fwPreZones) bixR).pzWordI
835835

836+
Pairing book-keeping ==================================================================================================
837+
838+
> modified = makeActions fWork (sy ^. psUnpaired)
839+
> dirty = IntMap.keysSet modified `IntSet.union` IntMap.keysSet partners
840+
> partners = IntMap.foldlWithKey sniffOut IntMap.empty (fWork ^. fwZoneOwners)
841+
> where
842+
> mirror =
843+
> let
844+
> reverser m iLeft iRight = IntMap.insert iRight iLeft m
845+
> oneWay = sy ^. psPaired
846+
> in
847+
> IntMap.foldlWithKey reverser oneWay oneWay
848+
>
849+
> sniffOut m iinst iset =
850+
> if not (IntSet.null residue)
851+
> then IntMap.insert iinst residue m
852+
> else m
853+
> where
854+
> allFound = IntSet.fromList $ mapMaybe (`IntMap.lookup` mirror) (IntSet.toList iset)
855+
> residue = allFound `IntSet.difference` iset
856+
836857
pairing convenience functions =========================================================================================
837858
unpair - cram all Ls and Rs from partner map into single set
838859
twoWay - complete the map (add R → L)
@@ -878,17 +899,14 @@ husband owners =================================================================
878899
>
879900
> repairOwners :: IntMap PreZone {- [BagIndex → pz] -}
880901
> → IntMap IntSet {- [InstIndex → [BagIndex]] -}
881-
> → IntMap a {- [InstIndex → a] -}
902+
> → IntSet {- [InstIndex] -}
882903
> → IntMap IntSet {- [InstIndex → [BagIndex]] -}
883-
> repairOwners pzdb owners essentialMap = refreshOwners pzdb (invalidateOwners owners instKeys)
904+
> repairOwners pzdb owners localDirty = refreshOwners pzdb (invalidateOwners owners localDirty)
884905
> where
885-
> instKeys =
886-
> (IntMap.keysSet owners) `IntSet.intersection` (IntMap.keysSet essentialMap)
887-
>
888906
> invalidateOwners = IntSet.foldl' (flip IntMap.delete)
889907
>
890908
> refreshOwners pzdb owners' = owners' `IntMap.union` makeOwners (IntMap.filter isInteresting pzdb)
891-
> isInteresting pz = (wordI pz) `IntSet.member` instKeys
909+
> isInteresting pz = (wordI pz) `IntSet.member` localDirty
892910

893911
vet task ==============================================================================================================
894912
switch bad stereo zones to mono, or off altogether
@@ -899,13 +917,13 @@ vet task =======================================================================
899917
> Directives{ .. }
900918
> = fWork ^. fwDirectives
901919
>
902-
> processed = IntMap.foldl' vetter (spawn fWork defVet) (fWork ^. fwZRecs)
903-
> work = imbibe fWork processed
920+
> processed :: Vet = IntMap.foldl' vetter (spawn fWork defVet) (fWork ^. fwZRecs)
921+
> work :: FileWork = imbibe fWork processed
904922
>
905923
> fixed = repairOwners
906924
> (work ^. fwPreZones)
907925
> (work ^. fwZoneOwners)
908-
> (work ^. fwPairing ^. fwZoneModified)
926+
> (work ^. fwDirty)
909927
>
910928
> vetter :: Vet → InstZoneRecord → Vet
911929
> vetter vetIn zrec =
@@ -964,30 +982,6 @@ adopt task =====================================================================
964982
> in
965983
> dispose (extractSampleKey pz) ssAdopt rdFold
966984

967-
rat task ==============================================================================================================
968-
rationalize exotic pairing
969-
970-
> ratTaskIf _ _ fWork = (fwZonePartners .~ partners) fWork
971-
> where
972-
> mirrored =
973-
> let
974-
> reverser m iLeft iRight = IntMap.insert iRight iLeft m
975-
> oneWay = fWork ^. (fwPairing . fwZonePairings)
976-
> in
977-
> IntMap.foldlWithKey reverser oneWay oneWay
978-
>
979-
> partners =
980-
> let
981-
> sniffOut m iinst iset =
982-
> if not (IntSet.null residue)
983-
> then IntMap.insert iinst residue m
984-
> else m
985-
> where
986-
> allFound = mapMaybe (`IntMap.lookup` mirrored) (IntSet.toList iset)
987-
> residue = (IntSet.fromList allFound) `IntSet.difference` iset
988-
> in
989-
> IntMap.foldlWithKey sniffOut IntMap.empty (fWork ^. fwZoneOwners)
990-
991985
smash task ============================================================================================================
992986
compute smashups for each instrument
993987
this is initiated multiple times, and only updates the zrec's smashup if it currently contains Nothing
@@ -1010,7 +1004,7 @@ smash task =====================================================================
10101004
>
10111005
> computeInstSmashup :: String → IntMap PreZone → IntSet → Smashing Word
10121006
> computeInstSmashup tag pzdb bixen
1013-
> | traceNow trace_CIS False = undefined
1007+
> | traceIf trace_CIS False = undefined
10141008
> | otherwise =
10151009
> profess
10161010
> ((not $ IntMap.null pzdb) && (not $ IntSet.null bixen))
@@ -1154,7 +1148,7 @@ To build the map
11541148
> owners' = repairOwners
11551149
> rebaseAbsorbed
11561150
> (fWork ^. fwZoneOwners)
1157-
> absorptionMap
1151+
> (IntMap.keysSet absorptionMap)
11581152

11591153
match task ============================================================================================================
11601154
accumulate all fuzzy matches
@@ -1175,12 +1169,18 @@ match task =====================================================================
11751169
> IntMap.foldl' computeFF Map.empty (fWork ^. fwZRecs)
11761170

11771171
shrink task ===========================================================================================================
1178-
Accounts for pairing activity-caused invalidations; when we have zones plugged in that are not owned
1179-
by the instrument, cause smashups to be recalculated (in later pass).
1172+
Accounts for pairing activity-caused invalidations; when instrument includes unowned zones, cause smashups
1173+
to be recalculated (in later pass).
11801174

11811175
> shrinkTaskIf _ _ fWork = zrecTask shrinker fWork
11821176
> where
1183-
> shrinker zrec rdFold = (Just zrec{zsSmashup = Nothing}, rdFold)
1177+
> shrinker zrec rdFold =
1178+
> let
1179+
> wInst = fromIntegral zrec.zswInst
1180+
> in
1181+
> case wInst `IntSet.member` (fWork ^. fwDirty) of
1182+
> True → (Just zrec{zsSmashup = Nothing}, rdFold)
1183+
> _ → (Just zrec , rdFold)
11841184

11851185
clean task ============================================================================================================
11861186
removing zrecs that have gone bad
@@ -1201,11 +1201,11 @@ perI task ======================================================================
12011201
> perITaskIf _ _ fWork = ((fwPerInstruments .~ perIs) . (fwDispositions .~ rdOut)) fWork
12021202
> where
12031203
> (perIs, rdOut) =
1204-
> IntMap.foldl' (uncurry perIFolder) (Map.empty, (fWork ^. fwDispositions)) (fWork ^. fwZRecs)
1204+
> IntMap.foldl' (uncurry makePerI) (Map.empty, (fWork ^. fwDispositions)) (fWork ^. fwZRecs)
12051205
>
1206-
> perIFolder :: Map PerGMKey PerInstrument → ResultDispositions
1206+
> makePerI :: Map PerGMKey PerInstrument → ResultDispositions
12071207
> → InstZoneRecord → (Map PerGMKey PerInstrument, ResultDispositions)
1208-
> perIFolder m rdFold zrec = (Map.insert pergm perI m, dispose pergm ssInstrument rdFold')
1208+
> makePerI m rdFold zrec = (Map.insert pergm perI m, dispose pergm ssInstrument rdFold')
12091209
> where
12101210
> fName = "perIFolder"
12111211
>
@@ -1233,7 +1233,7 @@ perI task ======================================================================
12331233
> blessZone rd bix = dispose (extractZoneKey pz) ssPreZone rd
12341234
> where pz = accessPreZone "blessZone" (fWork ^. fwPreZones) bix
12351235
> in
1236-
> IntSet.foldl' blessZone rdFold perI.pOwned
1236+
> IntSet.foldl' blessZone rdFold (allBixen perI)
12371237

12381238
Runner boilerplate ====================================================================================================
12391239

0 commit comments

Comments
 (0)