{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
module Grammar.Types
( Weight
, Grammar (..), Rule (..), Head, Activation, Body
, Term (..), Expand (..), Grammarly
, runGrammar, always, (/\), (\/)
, (|:), (-|), (-||), ($:), (|$:), (|->)
) where
import System.Random
import Text.Show.Functions ()
import Generate (Weight)
import Music
infix 6 :%:
infix 5 $:
infix 5 |$:
infixr 4 :-:
infix 3 :->
infix 3 |->
data Grammar meta a = Grammar { initial :: a, rules :: [Rule meta a] }
infix 2 |:
(|:) :: a -> [Rule meta a] -> Grammar meta a
initA |: rs = Grammar initA rs
data Rule meta a = Head a :-> Body meta a
type Head a = (a, Weight, Activation)
type Activation = Duration -> Bool
type Body meta a = Duration -> Term meta a
data Term meta a =
a :%: Duration
| Term meta a :-: Term meta a
| Aux Bool meta (Term meta a)
| Let (Term meta a) (Term meta a -> Term meta a)
deriving instance (Show a, Show meta) => Show (Term meta a)
instance (Eq a, Eq meta) => Eq (Term meta a) where
(a :%: d) == (a' :%: d') = a == a' && d == d'
(x :-: y) == (x' :-: y') = x == x' && y == y'
(Aux b meta t) == (Aux b' meta' t') = b == b' && meta == meta' && t == t'
(Let t _) == (Let t' _) = t == t'
_ == _ = False
instance Functor (Term meta) where
fmap f m = case m of
a :%: t -> f a :%: t
m1 :-: m2 -> (f <$> m1) :-: (f <$> m2)
Aux frozen meta m1 -> Aux frozen meta (f <$> m1)
_ -> error "fmap: let-expressions exist"
type Grammarly input a meta b =
(Show a, Show meta, Eq a, Eq meta, Expand input a meta b)
class Expand input a meta b | input a meta -> b where
expand :: input -> Term meta a -> IO (Term () b)
toMusic :: (Expand input a meta b) => input -> Term meta a -> IO (Music b)
toMusic input term = do
expanded <- expand input (unlet term)
go expanded
where go (a :%: t) = return $ Note t a
go (t :-: t') = (:+:) <$> toMusic () t <*> toMusic () t'
go _ = error "toMusic: lets/aux after expansion"
unlet (Let x k) = unlet (k x)
unlet (t :-: t') = unlet t :-: unlet t'
unlet (Aux b meta t) = Aux b meta (unlet t)
unlet t = t
instance Expand input a () a where
expand = const return
runGrammar :: Grammarly input a meta b
=> Grammar meta a -> Duration -> input -> IO (Music b)
runGrammar grammar initT input = do
rewritten <- fixpoint (go grammar) (initial grammar :%: initT)
toMusic input rewritten
where
go :: (Eq meta, Eq a) => Grammar meta a -> Term meta a -> IO (Term meta a)
go gram (Let x k) = do
x' <- go gram x
return $ Let x' k
go gram (t :-: t') =
(:-:) <$> go gram t <*> go gram t'
go _ a@(Aux True _ _) =
return a
go gram (Aux False meta term) =
Aux False meta <$> go gram term
go (Grammar _ rs) (a :%: t) = do
let rs' = filter (\((a', _, activ) :-> _) -> a' == a && activ t) rs
(_ :-> rewrite) <- pickRule a rs'
return $ rewrite t
always :: Activation
always = const True
(/\) :: Activation -> Activation -> Activation
(f /\ g) x = f x && g x
(\/) :: Activation -> Activation -> Activation
(f \/ g) x = f x || g x
(|->) :: Head a -> Term meta a -> Rule meta a
a |-> b = a :-> const b
(-|) :: a -> Weight -> Rule meta a
a -| w = (a, w, always) :-> \t -> a :%: t
(-||) :: (a, Weight) -> Activation -> Rule meta a
(a, w) -|| f = (a, w, f) :-> \t -> a :%: t
($:), (|$:) :: meta -> Term meta a -> Term meta a
($:) = Aux False
(|$:) = Aux True
pickRule :: a -> [Rule meta a] -> IO (Rule meta a)
pickRule a [] = return $ a -| 1
pickRule _ rs = do
let totalWeight = sum ((\((_, w, _) :-> _) -> w) <$> rs)
index <- getStdRandom $ randomR (0, totalWeight)
return $ pick' index rs
where pick' :: Double -> [Rule meta a] -> Rule meta a
pick' n (r@((_, w, _) :-> _):rest) =
if n <= w then r else pick' (n-w) rest
pick' _ _ = error "pick: empty list"
fixpoint :: Eq a => (a -> IO a) -> a -> IO a
fixpoint k l = do
l' <- k l
if l == l' then return l else fixpoint k l'