content: Probabilistic Temporal Graph Grammar Implementation
  Donya Quick
  Last modified: 20-Dec-2014
  
  Based on the original monadic implementation by Donya Quick and Paul Hudak 
  (see ICMC 2013 and FARM 2013 papers). 
  
  Major changes:
  - Removal of the S constructor for sentences.
  - Removal of Mod constructor. Modulation information will be stored as a parameter.
  - Chord constructor renamed to MSym to allow for PTGGs over other features.
  
  > module Kulitta.PTGG where
  > import Data.List
  > import System.Random
  
  The Term data structure has three constructors: 
      1. NT - a nonterminal that has a symbol and a parameter.
      2. Let - a means of capturing variable instantiation in a Term.
      3. Var - a variable	
  	
  > data Term a b = NT (a,b) | Let String (Sentence a b) (Sentence a b) | Var String
  >      deriving (Eq, Show)
  
  A Sentence is a list of Terms.
  
  > type Sentence a b = [Term a b]
  
  A rule has a left and righthand side. The lefthand side has
  an un-parameterized symbol and a probability for application of
  the rule. The righthand side is a function from a parameter to
  a Sentence.
  
  > type Prob = Double
  > data Rule a b = (a, Prob) :-> RuleFun a b
  > type RuleFun a b = b -> Sentence a b
  
  
  A function to rewrite one Sentence to another using an 
  L-System-like approach to generation where all symbols are 
  updated from left to right.
  
  > update :: (Eq a, Eq b) => [Rule a b] -> (StdGen, Sentence a b) -> (StdGen, Sentence a b)
  > update rules (g, []) = (g,[])
  > update rules (g,(t:ts)) = case t of
  >     NT (c,d)  -> let (g1, t') = applyRule rules g (c,d)
  >                      (g2, ts') = update rules (g1, ts) 
  >                  in  (g2, t'++ts')
  >     Let x a e -> let (g1,a') = update rules (g, a)
  >                      (g2,e') = update rules (g1, e)
  >                      (g3,ts') = update rules (g2, ts)
  >                  in  (g3, Let x a' e' : ts')
  >     x         -> let (g1, ts') = update rules (g, ts)
  >                  in  (g1, x : ts')
  
  Function to update a single symbol:
  
  > applyRule :: (Eq a) => [Rule a b] -> StdGen -> (a,b) -> (StdGen, Sentence a b)
  > applyRule rules g (c,d) =  
  >   let  rs = filter (\((c',p) :-> rf) -> c'==c) rules
  >        (p,g') = randomR (0.0::Double, 1.0) g
  >   in   if null rs then (g, [NT (c,d)]) else (g', choose rs p $ d) where -- See note below
  >       choose :: [Rule a b] -> Prob -> (RuleFun a b)
  >       choose [] p  = error "Nothing to choose from!"
  >       choose (((c,p') :-> rf):rs) p  = 
  >           if p<=p' || null rs then rf else choose rs (p-p') 
  
  Note: we assume the value is a NT (nonterminal) because applyRule can only
  be called from NT in update. We want to leave these as NTs rather than forcing
  them to terminals in case the user wishes to apply different rule sets later.
  
  User-level generation:
  
  > gen :: (Eq a, Eq b) => [Rule a b] -> (StdGen, Sentence a b) -> [(StdGen, Sentence a b)]
  > gen rules (g,t) = iterate (update rules) (g,t)
  
  The expand function eliminates Lets and Vars from a generated Term a.
  It allows for nested Let expressions for variables with the same name
  with lexical scoping. For example:
  
  expand [] [Let "x" t1 [Let "x" t2 (Var "x")]] ==> t2
  
  > expand :: [(String, Sentence a b)] -> Sentence a b -> Sentence a b
  > expand e [] = []
  > expand e (t:ts) = case t of 
  >     Let x a exp -> expand ((x, expand e a) : e) exp ++ expand e ts
  >     Var x       -> (maybe (error (x ++ " is undefined")) id $ lookup x e) ++ expand e ts
  >     x           -> x : expand e ts
  
  ------------------------------------------------------------------------
  
  Additional manipulations
  
  Map defined over Term to convert pairs of one type to pairs of another.
  
  > tMap :: ((a,b) -> (c,d)) -> Sentence a b -> Sentence c d
  > tMap f [] = []
  > tMap f (t:ts) = 
  >     let t' = case t of
  >                  Let x a exp -> Let x (tMap f a) (tMap f exp)
  >                  Var x -> Var x
  >                  NT x -> NT $ f x
  >     in  t' : tMap f ts
  
  Flattening completely to a list
  
  > toPairs :: Sentence a b -> [(a, b)]
  > toPairs = map f . expand [] where
  >     f (NT (ct, d)) = (ct,d) 
  >     f _ = error "(toPairs) Variable or Let expression encountered"
  
  Reassigning probabilities
  
  > updateProbs :: [Rule a b] -> [Prob] -> [Rule a b]
  > updateProbs rs ps = 
  >     if length rs /= length ps then error "(updateProbs) Probability/rule count mismatch."
  >     else zipWith (\((l,_):->rhs) p -> (l,p):->rhs) rs ps
  
  Accessing the various portions of a rule without pattern matching
  
  > lhs ((c,p) :-> rf) = c
  > prob ((c,p) :-> rf) = p
  > rfun ((c,p) :-> rf) = rf
  
  Normalize the probabilities for a rule set
  
  > normalize :: (Eq a) => [Rule a b] -> [Rule a b]
  > normalize [] = []
  > normalize (r@((l,p) :-> rf):rs) = 
  >     let rset = r : filter ((l==).lhs) rs
  >         rset' = filter ((l/=).lhs) rs
  >         psum = sum $ map prob rset
  >     in  map (\((l',p') :-> c') -> ((l',p'/psum) :-> c')) rset ++ normalize rset'
  