{-# LINE 8 "LSystems.lhs" #-}
--  This code was automatically generated by lhs2tex --code, from the file 
--  HSoM/LSystems.lhs.  (See HSoM/MakeCode.bat.)
{-# LINE 19 "LSystems.lhs" #-}
module Euterpea.Examples.LSystems where

import Euterpea
import Data.List hiding (transpose)
import System.Random 
{-# LINE 81 "LSystems.lhs" #-}
data DetGrammar a = DetGrammar  a           --  start symbol
                                [(a,[a])]   --  productions
  deriving Show
{-# LINE 89 "LSystems.lhs" #-}
detGenerate :: Eq a => DetGrammar a -> [[a]]
detGenerate (DetGrammar st ps) = iterate (concatMap f) [st]
            where f a = maybe [a] id (lookup a ps)
{-# LINE 131 "LSystems.lhs" #-}
redAlgae = DetGrammar 'a'
               [  ('a',"b|c"),   ('b',"b"),  ('c',"b|d"),
                  ('d',"e\\d"),  ('e',"f"),  ('f',"g"),
                  ('g',"h(a)"),  ('h',"h"),  ('|',"|"),
                  ('(',"("),     (')',")"),  ('/',"\\"),
                  ('\\',"/")
               ]
{-# LINE 157 "LSystems.lhs" #-}
t n g = sequence_ (map putStrLn (take n (detGenerate g)))
{-# LINE 221 "LSystems.lhs" #-}
data Grammar a = Grammar  a          --  start sentence
                          (Rules a)  --  production rules
     deriving Show
{-# LINE 232 "LSystems.lhs" #-}
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
{-# LINE 247 "LSystems.lhs" #-}
type ReplFun a  = [[(Rule a, Prob)]] -> (a, [Rand]) -> (a, [Rand])
type Rand       = Double
{-# LINE 264 "LSystems.lhs" #-}
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.")
{-# LINE 280 "LSystems.lhs" #-}
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)
{-# LINE 300 "LSystems.lhs" #-}
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
{-# LINE 317 "LSystems.lhs" #-}
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)
{-# LINE 347 "LSystems.lhs" #-}
data LSys a  =  N a 
             |  LSys a   :+   LSys a 
             |  LSys a   :.   LSys a 
             |  Id 
     deriving (Eq, Ord, Show) 
{-# LINE 366 "LSystems.lhs" #-}
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)
{-# LINE 384 "LSystems.lhs" #-}
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"
{-# LINE 405 "LSystems.lhs" #-}
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"
{-# LINE 418 "LSystems.lhs" #-}
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
{-# LINE 437 "LSystems.lhs" #-}
sc = inc :+ dec
{-# LINE 442 "LSystems.lhs" #-}
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
{-# LINE 452 "LSystems.lhs" #-}
g1 = Grammar same (Uni [r1b, r1a, r2b, r2a, r3a, r3b])
{-# LINE 458 "LSystems.lhs" #-}
t1 n =  instrument Vibraphone $
        interpret (gen replFun g1 42 !! n) ir (c 5 tn)