\subsection{Structure Analysis}
This module contains a function which builds
a hierarchical music object from a serial one.
This is achieved by searching for long common infixes.
A common infix is replaced by a single object
at each occurence.
This module proofs the sophistication of the separation
between general arrangement of some objects as provided by the \module{Medium}
and the special needs of music provided by the \module{Music}.
It's possible to formulate these algorithms without the knowledge of Music
and we can insert the type \code{Tag} to distinguish
between media primitives and macro calls.
The only drawback is that it is not possible to descend
into controlled sub-structures, like Tempo and Trans.
\begin{haskelllisting}
> module Medium.Controlled.ContextFreeGrammar
> (T, Tag(..), TagMedium, fromMedium, toMedium) where
> import qualified Medium.Controlled.List as CtrlMediumList
> import qualified Medium.Controlled as CtrlMedium
> import Medium.Plain.ContextFreeGrammar
> (Tag(..), joinTag, replaceInfix,
> whileM, smallestCycle, maximumCommonInfixMulti)
> import Medium (prim, serial1, parallel1)
> import Data.Maybe (fromJust)
> import qualified Haskore.General.Map as Map
> import Control.Monad.Trans.State (state, execState)
\end{haskelllisting}
Condense all common infixes down to length 'thres'.
The infixes are replaced by some marks using the constructor Left.
They can be considered as macros or
as non-terminals in a grammar.
The normal primitives are preserved with constructor Right.
We end up with a context-free grammar of the media.
\begin{haskelllisting}
> type TagMedium key control prim = CtrlMediumList.T control (Tag key prim)
> type T key control prim = [(key, TagMedium key control prim)]
> fromMedium :: (Ord key, Ord control, Ord prim) =>
> [key] -> Int -> CtrlMediumList.T control prim -> T key control prim
> fromMedium (key:keys) thres m =
> let action = whileM (>= thres) (map (state . condense) keys)
>
> in reverse $ execState action [(key, fmap Prim m)]
> fromMedium _ _ _ =
> error ("No key given."++
> " Please provide an infinite or at least huge number of macro names.")
\end{haskelllisting}
The inverse of \code{fromMedium}: Expand all macros.
Cyclic macro references shouldn't be a problem
if it is possible to resolve the dependencies.
We manage the grammar in the dictionary \code{dict}.
Now a naive way for expanding the macros
is to recourse into each macro call manually
using lookups to \code{dict}.
This would imply that we need new memory for each expansion of the same macro.
We have chosen a different approach:
We map \code{dict} to a new dictionary \code{dict'}
which contains the expanded versions of each Medium.
For expansion we don't use repeated lookups to \code{dict}
but we use only one lookup to \code{dict'}
-- which contains the fully expanded version of the considered Medium.
This method is rather the same as
if you write Haskell values that invokes each other.
The function \code{expand} computes the expansion for each key and
the function \code{toMedium} computes the expansion of the first macro.
Thus \code{toMedium} quite inverts \code{fromMedium}.
\begin{haskelllisting}
> toMedium :: (Show key, Ord key, Ord prim) =>
> T key control prim -> CtrlMediumList.T control prim
> toMedium = snd . head . expand
> expand :: (Show key, Ord key, Ord prim) =>
> T key control prim -> [(key, CtrlMediumList.T control prim)]
> expand grammar =
> let notFound key = error ("The non-terminal '" ++ show key ++ "' is unknown.")
> dict = Map.fromList grammar
> dict' = Map.map (CtrlMedium.foldList expandSub serial1 parallel1
> CtrlMedium.control) dict
> expandSub (Prim p) = prim p
> expandSub (Call key) =
> Map.findWithDefault dict' (notFound key) key
> expandSub (CallMulti n key) =
> serial1 (replicate n (Map.findWithDefault dict' (notFound key) key))
> in map (fromJust . Map.lookup (Map.mapWithKey (,) dict') . fst) grammar
\end{haskelllisting}
Find the longest common infix over all parts of the music
and replace it in all of them.
\begin{haskelllisting}
> condense :: (Ord key, Ord control, Ord prim) =>
> key
> -> T key control prim
> -> (Int, T key control prim)
> condense key x =
> let getSerials = CtrlMedium.switchList
> (const [])
> (\xs -> xs : concatMap getSerials xs)
> (\xs -> concatMap getSerials xs)
> (const getSerials)
> infx = smallestCycle (maximumCommonInfixMulti length
> (concatMap (getSerials . snd) x))
> absorbSingleton _ [m] = m
> absorbSingleton collect ms = collect ms
> replaceRec = CtrlMedium.foldList prim
> (absorbSingleton serial1 . map joinTag . replaceInfix key infx)
> (absorbSingleton parallel1)
> (CtrlMedium.control)
> in (length infx, (key, serial1 infx) : map (\(k, ms) -> (k, replaceRec ms)) x)
\end{haskelllisting}