-- This code was automatically generated by lhs2tex --code, from the file 
-- HSoM/LSystems.lhs.  (See HSoM/MakeCode.bat.)

module Euterpea.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)