\subsection{StructureAnalysis}Thismodulecontainsafunctionwhichbuildsahierarchicalmusicobjectfromaserialone.Thisisachievedbysearchingforlongcommoninfixes.Acommoninfixisreplacedbyasingleobjectateachoccurence.Thismoduleproofsthesophisticationoftheseparationbetweengeneralarrangementofsomeobjectsasprovidedbythe\module{Medium}andthespecialneedsofmusicprovidedbythe\module{Music}.It'spossibletoformulatethesealgorithmswithouttheknowledgeofMusicandwecaninsertthetype\code{Tag}todistinguishbetweenmediaprimitivesandmacrocalls.Theonlydrawbackisthatitisnotpossibletodescendintocontrolledsub-structures,likeTempoandTrans.\begin{haskelllisting}>moduleMedium.Plain.ContextFreeGrammarwhere>importData.List(sort,tails,isPrefixOf,findIndex)>importData.Maybe(fromJust)>importqualifiedHaskore.General.MapasMap>importHaskore.General.Utility(maximumKey,zapWith)>importControl.Monad.State(MonadState,put,get,State(State),execState)>importMedium(prim,serial1,parallel1)>importqualifiedMedium>importqualifiedMedium.Plain.ListasListMedium\end{haskelllisting}Condenseallcommoninfixesdowntolength'thres'.TheinfixesarereplacedbysomemarksusingtheconstructorLeft.Theycanbeconsideredasmacrosorasnon-terminalsinagrammar.ThenormalprimitivesarepreservedwithconstructorRight.Weendupwithacontext-freegrammarofthemedia.\begin{haskelllisting}>dataTagkeyprim=>Primprim>|Callkey>|CallMultiIntkey>deriving(Eq,Ord,Show)>typeTagMediumkeyprim=ListMedium.T(Tagkeyprim)>-- True is for cyclic infixes>typeTkeyprim=[(key,TagMediumkeyprim)]>fromMedium::(Ordkey,Ordprim)=>>[key]->Int->ListMedium.Tprim->Tkeyprim>fromMedium(key:keys)thresm=>letaction=whileM(>=thres)(map(State.condense)keys)>-- action = sequence (take 1 (map (State . condense) keys))>inreverse$execStateaction[(key,fmapPrimm)]>fromMedium___=>error("No key given."++>" Please provide an infinite or at least huge number of macro names.")\end{haskelllisting}Theinverseof\code{fromMedium}:Expandallmacros.Cyclicmacroreferencesshouldn'tbeaproblemifitispossibletoresolvethedependencies.Wemanagethegrammarinthedictionary\code{dict}.Nowanaivewayforexpandingthemacrosistorecurseintoeachmacrocallmanuallyusinglookupsto\code{dict}.Thiswouldimplythatweneednewmemoryforeachexpansionofthesamemacro.Wehavechosenadifferentapproach:Wemap\code{dict}toanewdictionary\code{dict'}whichcontainstheexpandedversionsofeachMedium.Forexpansionwedon'tuserepeatedlookupsto\code{dict}butweuseonlyonelookupto\code{dict'}-- which contains the fully expanded version of the considered Medium.ThismethodisratherthesameasifyouwriteHaskellvaluesthatinvokeseachother.Thefunction\code{expand}computestheexpansionforeachkeyandthefunction\code{toMedium}computestheexpansionofthefirstmacro.Thus\code{toMedium}quiteinverts\code{fromMedium}.\begin{haskelllisting}>toMedium::(Showkey,Ordkey,Ordprim)=>>Tkeyprim->ListMedium.Tprim>toMedium=snd.head.expand>expand::(Showkey,Ordkey,Ordprim)=>>Tkeyprim->[(key,ListMedium.Tprim)]>expandgrammar=>letnotFoundkey=error("The non-terminal '"++showkey++"' is unknown.")>dict=Map.fromListgrammar>dict'=Map.map(Medium.foldListexpandSubserial1parallel1)dict>expandSub(Primp)=primp>expandSub(Callkey)=>Map.findWithDefaultdict'(notFoundkey)key>expandSub(CallMultinkey)=>serial1(replicaten(Map.findWithDefaultdict'(notFoundkey)key))>inmap(fromJust.Map.lookup(Map.mapWithKey(,)dict').fst)grammar\end{haskelllisting}Domonadicactionsuntilthecondition\code{p}fails.ThisisimplementedforStateMonads,becauseinplainMonadsonecouldnotresetthestateandthusthestatewouldn'tbethatafterthelastsuccessful(withrespecttothepredicate\code{p})action.\begin{haskelllisting}>whileM::(MonadStatesm)=>(a->Bool)->[ma]->m[a]>whileM_[]=return[]>whileMp(m:ms)=>dos<-get>x<-m>ifpxthenwhileMpms>>=return.(x:)>elseputs-- reset to the old state>>>return[]\end{haskelllisting}Findthelongestcommoninfixoverallpartsofthemusicandreplaceitinallofthem.\begin{haskelllisting}>condense::(Ordkey,Ordprim)=>>key>->Tkeyprim>->(Int,Tkeyprim)>condensekeyx=>letgetSerials=Medium.switchList>(const[])>(\xs->xs:concatMapgetSerialsxs)>(\xs->concatMapgetSerialsxs)>infx=smallestCycle(maximumCommonInfixMultilength>(concatMap(getSerials.snd)x))>absorbSingleton_[m]=m>absorbSingletoncollectms=collectms>replaceRec=Medium.foldListprim>(absorbSingletonserial1.mapjoinTag.replaceInfixkeyinfx)>(absorbSingletonparallel1)>in(lengthinfx,(key,serial1infx):map(\(k,ms)->(k,replaceRecms))x)>joinTag::Medium.Constructmedium=>>Tagkey(medium(Tagkeyprim))->medium(Tagkeyprim)>joinTag(Primm)=m>joinTag(Callk)=prim(Callk)>joinTag(CallMultink)=prim(CallMultink)\end{haskelllisting}Replacealloccurencesoftheinfixbyitskey.Collectaccumulatedoccurencesinone\code{CallMulti}.\begin{haskelllisting}>replaceInfix::(Eqa,Eqb)=>>a>->[b]>->[b]>->[Tagab]>replaceInfixkeyinfxsequ=>letrecurse[]=[]>recursexa@(x:xs)=>letpref=commonPrefix(cycleinfx)xa>(num,r)=divMod(lengthpref)(lengthinfx)>len=lengthpref-r>inifnum==0>thenPrimx:recursexs>else((ifnum==1thenCallkeyelseCallMultinumkey)>:recurse(droplenxa))>inrecursesequ\end{haskelllisting}Acommoninfixindicatesaloopifitsoccurencesoverlap.Wecandetectthisbycheckingifthereisasuffixofourlistwhichisalsoaprefixofthislist.\begin{haskelllisting}>isCyclic::Eqa=>[a]->Bool>isCyclicx=any(flipisPrefixOfx)(init(tail(tailsx)))\end{haskelllisting}Findtheshortestlist\code{y},where\code{x}isaprefixof\code{cycley}.If\code{x}hasnoloop,then\code{x==y}.\begin{haskelllisting}>smallestCycle::Eqa=>[a]->[a]>smallestCyclex=>take(1+fromJust(findIndex(flipisPrefixOfx)(tail(tailsx))))x\end{haskelllisting}Findingcommoninfixesisaprominentapplicationofsuffixtrees.ButsinceIdon'thaveanimplementationofsuffixtreesI'llsticktoasortedlistofsuffices.\begin{haskelllisting}>maximumCommonInfix::(Orda,Ordb)=>([a]->b)->[a]->[a]>maximumCommonInfixmag=>maximumKeymag.>zapWithcommonPrefix.>sort.tails\end{haskelllisting}Findcommoninfixesacrossmultiplestrings.Thiscouldbeaniceapplicationofgeneralizedsuffixtrees.\begin{haskelllisting}>maximumCommonInfixMulti::(Orda,Ordb)=>([a]->b)->[[a]]->[a]>maximumCommonInfixMultimag=>maximumKeymag.>zapWithcommonPrefix.>sort.concatMaptails\end{haskelllisting}Findthelongestcommonprefix.(Twoimplementationsthatmaybeusedfortesting.)\begin{haskelllisting}>commonPrefix::Eqa=>[a]->[a]->[a]>commonPrefixxsys=>mapfst$takeWhile(uncurry(==))$zipxsys>commonPrefixRec::Eqa=>[a]->[a]->[a]>commonPrefixRec(x:xs)(y:ys)=>ifx==y>thenx:commonPrefixxsys>else[]>commonPrefixRec__=[]\end{haskelllisting}