content: > module HSoM.Examples.LSystems where
  > import Euterpea
  > import Data.List hiding (transpose)
  > import System.Random 
  
  > data DetGrammar a = DetGrammar  a           --  start symbol
  >                                 [(a,[a])]   --  productions
  >   deriving Show
  
  > detGenerate :: Eq a => DetGrammar a -> [[a]]
  > detGenerate (DetGrammar st ps) = iterate (concatMap f) [st]
  >             where f a = maybe [a] id (lookup a ps)
  
  > redAlgae = DetGrammar 'a'
  >                [  ('a',"b|c"),   ('b',"b"),  ('c',"b|d"),
  >                   ('d',"e\\d"),  ('e',"f"),  ('f',"g"),
  >                   ('g',"h(a)"),  ('h',"h"),  ('|',"|"),
  >                   ('(',"("),     (')',")"),  ('/',"\\"),
  >                   ('\\',"/")
  >                ]
  
  > t n g = sequence_ (map putStrLn (take n (detGenerate g)))
  
  > data Grammar a = Grammar  a          --  start sentence
  >                           (Rules a)  --  production rules
  >      deriving Show
  
  > data Rules a  =  Uni  [Rule a] 
  >               |  Sto  [(Rule a, Prob)]
  >      deriving (Eq, Ord, Show)
  
  > data Rule a = Rule { lhs :: a, rhs :: a }
  >      deriving (Eq, Ord, Show)
  
  > type Prob = Double
  > type ReplFun a  = [[(Rule a, Prob)]] -> (a, [Rand]) -> (a, [Rand])
  > type Rand       = Double
  
  > gen :: Ord a => ReplFun a -> Grammar a -> Int -> [a]
  > gen f (Grammar s rules) seed = 
  >     let  Sto newRules  = toStoRules rules
  >          rands         = randomRs (0.0,1.0) (mkStdGen seed)
  >     in  if checkProbs newRules
  >         then generate f newRules (s,rands)
  >         else (error "Stochastic rule-set is malformed.")
  
  > toStoRules :: (Ord a, Eq a) => Rules a -> Rules a  
  > toStoRules (Sto rs)  = Sto rs
  > toStoRules (Uni rs)  = 
  >   let rs' = groupBy (\r1 r2 -> lhs r1 == lhs r2) (sort rs)
  >   in Sto (concatMap insertProb rs')
  
  > insertProb :: [a] -> [(a, Prob)] 
  > insertProb rules =  let prb = 1.0 / fromIntegral (length rules)
  >                     in zip rules (repeat prb)
  
  > checkProbs :: (Ord a, Eq a) => [(Rule a, Prob)] -> Bool
  > checkProbs rs = and (map checkSum (groupBy sameLHS (sort rs)))
  
  > eps = 0.001 
  
  > checkSum :: [(Rule a, Prob)] -> Bool 
  > checkSum rules =  let mySum = sum (map snd rules)
  >                   in abs (1.0 - mySum) <= eps 
  
  > sameLHS :: Eq a => (Rule a, Prob) -> (Rule a, Prob) -> Bool 
  > sameLHS (r1,f1) (r2,f2) = lhs r1 == lhs r2
  
  > generate ::  Eq a =>  
  >              ReplFun a -> [(Rule a, Prob)] -> (a,[Rand]) -> [a] 
  > generate f rules xs = 
  >   let  newRules      =  map probDist (groupBy sameLHS rules)
  >        probDist rrs  =  let (rs,ps) = unzip rrs
  >                         in zip rs (tail (scanl (+) 0 ps))
  >   in map fst (iterate (f newRules) xs)
  
  > data LSys a  =  N a 
  >              |  LSys a   :+   LSys a 
  >              |  LSys a   :.   LSys a 
  >              |  Id 
  >      deriving (Eq, Ord, Show) 
  
  > replFun :: Eq a => ReplFun (LSys a)
  > replFun rules (s, rands) =
  >   case s of
  >     a :+ b  ->  let  (a',rands')   = replFun rules (a, rands )
  >                      (b',rands'')  = replFun rules (b, rands')
  >                 in (a' :+ b', rands'')
  >     a :. b  ->  let  (a',rands')   = replFun rules (a, rands )
  >                      (b',rands'')  = replFun rules (b, rands')
  >                 in (a' :. b', rands'')
  >     Id      ->  (Id, rands)
  >     N x     ->  (getNewRHS rules (N x) (head rands), tail rands)
  
  > getNewRHS :: Eq a => [[(Rule a, Prob)]] -> a -> Rand -> a
  > getNewRHS rrs ls rand = 
  >   let  loop ((r,p):rs)  = if rand <= p then rhs r else loop rs
  >        loop []          = error "getNewRHS anomaly"
  >   in case (find (\ ((r,p):_) -> lhs r == ls) rrs) of
  >         Just rs  -> loop rs
  >         Nothing  -> error "No rule match"
  
  > type IR a b = [(a, Music b -> Music b)]  --  ``interpetation rules'' 
  
  > interpret :: (Eq a) => LSys a -> IR a b -> Music b -> Music b
  > interpret (a :. b)  r m = interpret a r (interpret b r m)  
  > interpret (a :+ b)  r m = interpret a r m :+: interpret b r m
  > interpret Id        r m = m 
  > interpret (N x)     r m = case (lookup x r) of
  >                             Just f   -> f m
  >                             Nothing  -> error "No interpetation rule"
  
  > data LFun = Inc | Dec | Same
  >      deriving (Eq, Ord, Show)
  
  > ir :: IR LFun Pitch
  > ir = [ (Inc, transpose 1),
  >        (Dec, transpose (-1)),
  >        (Same, id)]
  
  > inc, dec, same :: LSys LFun
  > inc   = N Inc
  > dec   = N Dec
  > same  = N Same
  
  > sc = inc :+ dec
  
  > r1a  = Rule inc (sc :. sc)
  > r1b  = Rule inc sc
  > r2a  = Rule dec (sc :. sc)
  > r2b  = Rule dec sc
  > r3a  = Rule same inc
  > r3b  = Rule same dec
  > r3c  = Rule same same
  
  > g1 = Grammar same (Uni [r1b, r1a, r2b, r2a, r3a, r3b])
  
  > t1 n =  instrument Vibraphone $
  >         interpret (gen replFun g1 42 !! n) ir (c 5 tn)
  