-- | Kevin Jones. "Compositional Applications of Stochastic Processes".
--   Computer Music Journal, 5(2):45-58, 1981.
module Music.Theory.Random.Jones_1981 where

import Data.List {- base -}
import Data.Maybe {- base -}
import System.Random {- random -}

-- * Stochastic Finite State Grammars

data G a = T a | P (G a) (G a) deriving (G a -> G a -> Bool
forall a. Eq a => G a -> G a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: G a -> G a -> Bool
$c/= :: forall a. Eq a => G a -> G a -> Bool
== :: G a -> G a -> Bool
$c== :: forall a. Eq a => G a -> G a -> Bool
Eq,Int -> G a -> ShowS
forall a. Show a => Int -> G a -> ShowS
forall a. Show a => [G a] -> ShowS
forall a. Show a => G a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [G a] -> ShowS
$cshowList :: forall a. Show a => [G a] -> ShowS
show :: G a -> String
$cshow :: forall a. Show a => G a -> String
showsPrec :: Int -> G a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> G a -> ShowS
Show)

type Rule k a = k -> a -> Maybe (a,a)
type Probablities k r = (r,[(k,r)])
type SFSG k a r = (Rule k a,Probablities k r)

-- > p_verify (1/2,[('a',1/4),('b',1/4)]) == True
p_verify :: (Eq a,Num a) => Probablities k a -> Bool
p_verify :: forall a k. (Eq a, Num a) => Probablities k a -> Bool
p_verify (a
t,[(k, a)]
k) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (a
t forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(k, a)]
k) forall a. Eq a => a -> a -> Bool
== a
1

p_select :: (Ord a, Num a) => Probablities k a -> a -> Maybe (Maybe k)
p_select :: forall a k.
(Ord a, Num a) =>
Probablities k a -> a -> Maybe (Maybe k)
p_select (a
t,[(k, a)]
k) =
  let windex :: [a] -> a -> Maybe Int
windex [a]
w a
n = forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (a
n forall a. Ord a => a -> a -> Bool
<) (forall a. (a -> a -> a) -> [a] -> [a]
scanl1 forall a. Num a => a -> a -> a
(+) [a]
w)
      ([k]
kk,[a]
kn) = forall a b. [(a, b)] -> ([a], [b])
unzip [(k, a)]
k
      f :: Int -> Maybe k
f Int
i = case Int
i of
              Int
0 -> forall a. Maybe a
Nothing
              Int
_ -> forall a. a -> Maybe a
Just ([k]
kk forall a. [a] -> Int -> a
!! (Int
i forall a. Num a => a -> a -> a
- Int
1))
  in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Maybe k
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Ord a, Num a) => [a] -> a -> Maybe Int
windex (a
t forall a. a -> [a] -> [a]
: [a]
kn)

-- > let p = (1/2,[('a',1/4),('b',1/4)])
-- > map (p_select_err p) [0,0.5,0.75] == [Nothing,Just 'a',Just 'b']
p_select_err :: (Ord a, Num a) => Probablities k a -> a -> Maybe k
p_select_err :: forall a k. (Ord a, Num a) => Probablities k a -> a -> Maybe k
p_select_err Probablities k a
p = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"p_select") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k.
(Ord a, Num a) =>
Probablities k a -> a -> Maybe (Maybe k)
p_select Probablities k a
p

g_collect :: G a -> [a]
g_collect :: forall a. G a -> [a]
g_collect G a
g =
  case G a
g of
    T a
e -> [a
e]
    P G a
p G a
q -> forall a. G a -> [a]
g_collect G a
p forall a. [a] -> [a] -> [a]
++ forall a. G a -> [a]
g_collect G a
q

unfold :: (RandomGen g,Random r,Ord r,Num r) => SFSG k a r -> a -> g -> (G a,g)
unfold :: forall g r k a.
(RandomGen g, Random r, Ord r, Num r) =>
SFSG k a r -> a -> g -> (G a, g)
unfold (Rule k a
r,Probablities k r
p) a
st g
g =
  let (r
n,g
g') = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (r
0,r
1) g
g
  in case forall a k. (Ord a, Num a) => Probablities k a -> a -> Maybe k
p_select_err Probablities k r
p r
n of
       Maybe k
Nothing -> (forall a. a -> G a
T a
st,g
g')
       Just k
k ->
         case Rule k a
r k
k a
st of
           Maybe (a, a)
Nothing -> (forall a. a -> G a
T a
st,g
g')
           Just (a
i,a
j) ->
             let (G a
i',g
g'') = forall g r k a.
(RandomGen g, Random r, Ord r, Num r) =>
SFSG k a r -> a -> g -> (G a, g)
unfold (Rule k a
r,Probablities k r
p) a
i g
g'
                 (G a
j',g
g''') = forall g r k a.
(RandomGen g, Random r, Ord r, Num r) =>
SFSG k a r -> a -> g -> (G a, g)
unfold (Rule k a
r,Probablities k r
p) a
j g
g''
             in (forall a. G a -> G a -> G a
P G a
i' G a
j',g
g''')

sfsg_chain :: (RandomGen g,Random r,Ord r,Num r) => SFSG k a r -> a -> g -> [G a]
sfsg_chain :: forall g r k a.
(RandomGen g, Random r, Ord r, Num r) =>
SFSG k a r -> a -> g -> [G a]
sfsg_chain SFSG k a r
gr a
st g
g =
  let (G a
x,g
g') = forall g r k a.
(RandomGen g, Random r, Ord r, Num r) =>
SFSG k a r -> a -> g -> (G a, g)
unfold SFSG k a r
gr a
st g
g
  in G a
x forall a. a -> [a] -> [a]
: forall g r k a.
(RandomGen g, Random r, Ord r, Num r) =>
SFSG k a r -> a -> g -> [G a]
sfsg_chain SFSG k a r
gr a
st g
g'

sfsg_chain_n :: (RandomGen g,Random r,Ord r,Num r) => Int -> SFSG k a r -> a -> g -> [G a]
sfsg_chain_n :: forall g r k a.
(RandomGen g, Random r, Ord r, Num r) =>
Int -> SFSG k a r -> a -> g -> [G a]
sfsg_chain_n Int
n SFSG k a r
gr a
st = forall a. Int -> [a] -> [a]
take Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g r k a.
(RandomGen g, Random r, Ord r, Num r) =>
SFSG k a r -> a -> g -> [G a]
sfsg_chain SFSG k a r
gr a
st