{- | /Bel(R)/ is a simplified form of the /Bel/ notation described in:

- Bernard Bel.
  \"Time and musical structures\".
  /Interface (Journal of New Music Research)/
  Volume 19, Issue 2-3, 1990.
  (<http://hal.archives-ouvertes.fr/hal-00134160>)

- Bernard Bel.
  \"Two algorithms for the instantiation of structures of musical objects\".
  Centre National de la Recherche Scientifique, 1992. /GRTC 458/
  (<http://www.lpl.univ-aix.fr/~belbernard/music/2algorithms.pdf>)

For details see <http://rohandrape.net/?t=hmt-texts>.
-}

module Music.Theory.Time.Bel1990.R where

import Control.Monad {- base -}
import Data.Function {- base -}
import Data.List {- base -}
import Data.Ratio {- base -}

import qualified Text.Parsec as P {- parsec -}

import qualified Music.Theory.List as T
import qualified Music.Theory.Parse as T
import qualified Music.Theory.Show as T

-- * Bel

-- | Types of 'Par' nodes.
data Par_Mode = Par_Left | Par_Right | Par_Min | Par_Max | Par_None
  deriving (Par_Mode -> Par_Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Par_Mode -> Par_Mode -> Bool
$c/= :: Par_Mode -> Par_Mode -> Bool
== :: Par_Mode -> Par_Mode -> Bool
$c== :: Par_Mode -> Par_Mode -> Bool
Eq, Int -> Par_Mode -> ShowS
[Par_Mode] -> ShowS
Par_Mode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Par_Mode] -> ShowS
$cshowList :: [Par_Mode] -> ShowS
show :: Par_Mode -> [Char]
$cshow :: Par_Mode -> [Char]
showsPrec :: Int -> Par_Mode -> ShowS
$cshowsPrec :: Int -> Par_Mode -> ShowS
Show)

-- | The different 'Par' modes are indicated by bracket types.
par_mode_brackets :: Par_Mode -> (String,String)
par_mode_brackets :: Par_Mode -> ([Char], [Char])
par_mode_brackets Par_Mode
m =
    case Par_Mode
m of
      Par_Mode
Par_Left -> ([Char]
"(",[Char]
")")
      Par_Mode
Par_Right -> ([Char]
"~(",[Char]
")")
      Par_Mode
Par_Min -> ([Char]
"~{",[Char]
"}")
      Par_Mode
Par_Max -> ([Char]
"{",[Char]
"}")
      Par_Mode
Par_None -> ([Char]
"[",[Char]
"]")

-- | Inverse of par_mode_brackets
par_mode_kind :: (String, String) -> Par_Mode
par_mode_kind :: ([Char], [Char]) -> Par_Mode
par_mode_kind ([Char], [Char])
brk =
  case ([Char], [Char])
brk of
    ([Char]
"{",[Char]
"}") -> Par_Mode
Par_Max
    ([Char]
"~{",[Char]
"}") -> Par_Mode
Par_Min
    ([Char]
"(",[Char]
")") -> Par_Mode
Par_Left
    ([Char]
"~(",[Char]
")") -> Par_Mode
Par_Right
    ([Char]
"[",[Char]
"]") -> Par_Mode
Par_None
    ([Char], [Char])
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"par_mode_kind: incoherent par"

bel_brackets_match :: (Char,Char) -> Bool
bel_brackets_match :: (Char, Char) -> Bool
bel_brackets_match (Char
open,Char
close) =
    case (Char
open,Char
close) of
      (Char
'{',Char
'}') -> Bool
True
      (Char
'(',Char
')') -> Bool
True
      (Char
'[',Char
']') -> Bool
True
      (Char, Char)
_ -> Bool
False

{- | Tempo is rational.
The duration of a 'Term' is the reciprocal of the 'Tempo' that is in place at the 'Term'.
-}
type Tempo = Rational

-- | Terms are the leaf nodes of the temporal structure.
data Term a = Value a | Rest | Continue
  deriving (Term a -> Term a -> Bool
forall a. Eq a => Term a -> Term a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Term a -> Term a -> Bool
$c/= :: forall a. Eq a => Term a -> Term a -> Bool
== :: Term a -> Term a -> Bool
$c== :: forall a. Eq a => Term a -> Term a -> Bool
Eq,Int -> Term a -> ShowS
forall a. Show a => Int -> Term a -> ShowS
forall a. Show a => [Term a] -> ShowS
forall a. Show a => Term a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Term a] -> ShowS
$cshowList :: forall a. Show a => [Term a] -> ShowS
show :: Term a -> [Char]
$cshow :: forall a. Show a => Term a -> [Char]
showsPrec :: Int -> Term a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Term a -> ShowS
Show)

-- | Value of Term, else Nothing
term_value :: Term t -> Maybe t
term_value :: forall t. Term t -> Maybe t
term_value Term t
t =
  case Term t
t of
    Value t
x -> forall a. a -> Maybe a
Just t
x
    Term t
_ -> forall a. Maybe a
Nothing

-- | Recursive temporal structure.
data Bel a =
  Node (Term a) -- ^ Leaf node
  | Iso (Bel a) -- ^ Isolate
  | Seq (Bel a) (Bel a) -- ^ Sequence
  | Par Par_Mode (Bel a) (Bel a) -- ^ Parallel
  | Mul Tempo -- ^ Tempo multiplier
  deriving (Bel a -> Bel a -> Bool
forall a. Eq a => Bel a -> Bel a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bel a -> Bel a -> Bool
$c/= :: forall a. Eq a => Bel a -> Bel a -> Bool
== :: Bel a -> Bel a -> Bool
$c== :: forall a. Eq a => Bel a -> Bel a -> Bool
Eq,Int -> Bel a -> ShowS
forall a. Show a => Int -> Bel a -> ShowS
forall a. Show a => [Bel a] -> ShowS
forall a. Show a => Bel a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Bel a] -> ShowS
$cshowList :: forall a. Show a => [Bel a] -> ShowS
show :: Bel a -> [Char]
$cshow :: forall a. Show a => Bel a -> [Char]
showsPrec :: Int -> Bel a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Bel a -> ShowS
Show)

-- | Given a Par mode, generate either: 1. an Iso, 2. a Par, 3. a series of nested Par.
par_of :: Par_Mode -> [Bel a] -> Bel a
par_of :: forall a. Par_Mode -> [Bel a] -> Bel a
par_of Par_Mode
m [Bel a]
l =
  case [Bel a]
l of
    [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"par_of: null"
    [Bel a
e] -> forall a. Bel a -> Bel a
Iso Bel a
e
    Bel a
lhs : Bel a
rhs : [] -> forall a. Par_Mode -> Bel a -> Bel a -> Bel a
Par Par_Mode
m Bel a
lhs Bel a
rhs
    Bel a
e : [Bel a]
l' -> forall a. Par_Mode -> Bel a -> Bel a -> Bel a
Par Par_Mode
m Bel a
e (forall a. Par_Mode -> [Bel a] -> Bel a
par_of Par_Mode
m [Bel a]
l')

{- | Pretty printer for 'Bel', given pretty printer for the term type.
Note this does not write nested Par nodes in their simplified form.
-}
bel_pp :: (a -> String) -> Bel a -> String
bel_pp :: forall a. (a -> [Char]) -> Bel a -> [Char]
bel_pp a -> [Char]
f Bel a
b =
    case Bel a
b of
      Node Term a
Rest -> [Char]
"-"
      Node Term a
Continue -> [Char]
"_"
      Node (Value a
c) -> a -> [Char]
f a
c
      Iso Bel a
b' -> forall a. ([a], [a]) -> [a] -> [a]
T.bracket_l ([Char]
"{",[Char]
"}") (forall a. (a -> [Char]) -> Bel a -> [Char]
bel_pp a -> [Char]
f Bel a
b')
      Seq Bel a
p Bel a
q -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall a. (a -> [Char]) -> Bel a -> [Char]
bel_pp a -> [Char]
f Bel a
p,forall a. (a -> [Char]) -> Bel a -> [Char]
bel_pp a -> [Char]
f Bel a
q]
      Par Par_Mode
m Bel a
p Bel a
q ->
          let pq :: [Char]
pq = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall a. (a -> [Char]) -> Bel a -> [Char]
bel_pp a -> [Char]
f Bel a
p,[Char]
",",forall a. (a -> [Char]) -> Bel a -> [Char]
bel_pp a -> [Char]
f Bel a
q]
          in forall a. ([a], [a]) -> [a] -> [a]
T.bracket_l (Par_Mode -> ([Char], [Char])
par_mode_brackets Par_Mode
m) [Char]
pq
      Mul Tempo
n -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"*",forall a. (Show a, Integral a) => Ratio a -> [Char]
T.rational_pp Tempo
n]

-- | 'bel_pp' of 'return'.
bel_char_pp :: Bel Char -> String
bel_char_pp :: Bel Char -> [Char]
bel_char_pp = forall a. (a -> [Char]) -> Bel a -> [Char]
bel_pp forall (m :: * -> *) a. Monad m => a -> m a
return

{- | Analyse a Par node giving (duration,LHS-tempo-*,RHS-tempo-*).

> par_analyse 1 Par_Left (nseq "cd") (nseq "efg") == (2,1,3/2)
> par_analyse 1 Par_Right (nseq "cd") (nseq "efg") == (3,2/3,1)
> par_analyse 1 Par_Min (nseq "cd") (nseq "efg") == (2,1,3/2)
> par_analyse 1 Par_Max (nseq "cd") (nseq "efg") == (3,2/3,1)
> par_analyse 1 Par_None (nseq "cd") (nseq "efg") == (3,1,1)
-}
par_analyse :: Tempo -> Par_Mode -> Bel a -> Bel a -> (Rational,Rational,Rational)
par_analyse :: forall a.
Tempo -> Par_Mode -> Bel a -> Bel a -> (Tempo, Tempo, Tempo)
par_analyse Tempo
t Par_Mode
m Bel a
p Bel a
q =
    let (Tempo
_,Tempo
d_p) = forall a. Tempo -> Bel a -> (Tempo, Tempo)
bel_tdur Tempo
t Bel a
p
        (Tempo
_,Tempo
d_q) = forall a. Tempo -> Bel a -> (Tempo, Tempo)
bel_tdur Tempo
t Bel a
q
    in case Par_Mode
m of
         Par_Mode
Par_Left -> (Tempo
d_p,Tempo
1,Tempo
d_q forall a. Fractional a => a -> a -> a
/ Tempo
d_p)
         Par_Mode
Par_Right -> (Tempo
d_q,Tempo
d_p forall a. Fractional a => a -> a -> a
/ Tempo
d_q,Tempo
1)
         Par_Mode
Par_Min -> let r :: Tempo
r = forall a. Ord a => a -> a -> a
min Tempo
d_p Tempo
d_q in (Tempo
r,Tempo
d_p forall a. Fractional a => a -> a -> a
/ Tempo
r,Tempo
d_q forall a. Fractional a => a -> a -> a
/ Tempo
r)
         Par_Mode
Par_Max -> let r :: Tempo
r = forall a. Ord a => a -> a -> a
max Tempo
d_p Tempo
d_q in (Tempo
r,Tempo
d_p forall a. Fractional a => a -> a -> a
/ Tempo
r,Tempo
d_q forall a. Fractional a => a -> a -> a
/ Tempo
r)
         Par_Mode
Par_None -> (forall a. Ord a => a -> a -> a
max Tempo
d_p Tempo
d_q,Tempo
1,Tempo
1)

-- | Duration element of 'par_analyse'.
par_dur :: Tempo -> Par_Mode -> Bel a -> Bel a -> Rational
par_dur :: forall a. Tempo -> Par_Mode -> Bel a -> Bel a -> Tempo
par_dur Tempo
t Par_Mode
m Bel a
p Bel a
q =
    let (Tempo
d,Tempo
_,Tempo
_) = forall a.
Tempo -> Par_Mode -> Bel a -> Bel a -> (Tempo, Tempo, Tempo)
par_analyse Tempo
t Par_Mode
m Bel a
p Bel a
q
    in Tempo
d

-- | Calculate final tempo and duration of 'Bel'.
bel_tdur :: Tempo -> Bel a -> (Tempo,Rational)
bel_tdur :: forall a. Tempo -> Bel a -> (Tempo, Tempo)
bel_tdur Tempo
t Bel a
b =
    case Bel a
b of
      Node Term a
_ -> (Tempo
t,Tempo
1 forall a. Fractional a => a -> a -> a
/ Tempo
t)
      Iso Bel a
b' -> (Tempo
t,forall a b. (a, b) -> b
snd (forall a. Tempo -> Bel a -> (Tempo, Tempo)
bel_tdur Tempo
t Bel a
b'))
      Seq Bel a
p Bel a
q ->
          let (Tempo
t_p,Tempo
d_p) = forall a. Tempo -> Bel a -> (Tempo, Tempo)
bel_tdur Tempo
t Bel a
p
              (Tempo
t_q,Tempo
d_q) = forall a. Tempo -> Bel a -> (Tempo, Tempo)
bel_tdur Tempo
t_p Bel a
q
          in (Tempo
t_q,Tempo
d_p forall a. Num a => a -> a -> a
+ Tempo
d_q)
      Par Par_Mode
m Bel a
p Bel a
q -> (Tempo
t,forall a. Tempo -> Par_Mode -> Bel a -> Bel a -> Tempo
par_dur Tempo
t Par_Mode
m Bel a
p Bel a
q)
      Mul Tempo
n -> (Tempo
t forall a. Num a => a -> a -> a
* Tempo
n,Tempo
0)

-- | 'snd' of 'bel_tdur'.
bel_dur :: Tempo -> Bel a -> Rational
bel_dur :: forall a. Tempo -> Bel a -> Tempo
bel_dur Tempo
t = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tempo -> Bel a -> (Tempo, Tempo)
bel_tdur Tempo
t

-- * Linearisation

-- | Time point.
type Time = Rational

{- | Voices are named as a sequence of left and right directions within nested 'Par' structures.
l is left and r is right.
-}
type Voice = [Char]

{- | Linear state.
'Time' is the start time of the term.
'Tempo' is the active tempo & therefore the reciprocal of the duration.
'Voice' is the part label.
-}
type L_St = (Time, Tempo, Voice)

-- | Linear term.
type L_Term a = (L_St,Term a)

-- | Start time of 'L_Term'.
lterm_time :: L_Term a -> Time
lterm_time :: forall a. L_Term a -> Tempo
lterm_time ((Tempo
st,Tempo
_,[Char]
_),Term a
_) = Tempo
st

-- | Duration of 'L_Term' (reciprocal of tempo).
lterm_duration :: L_Term a -> Time
lterm_duration :: forall a. L_Term a -> Tempo
lterm_duration ((Tempo
_,Tempo
tm,[Char]
_),Term a
_) = Tempo
1 forall a. Fractional a => a -> a -> a
/ Tempo
tm

-- | End time of 'L_Term'.
lterm_end_time :: L_Term a -> Time
lterm_end_time :: forall a. L_Term a -> Tempo
lterm_end_time L_Term a
e = forall a. L_Term a -> Tempo
lterm_time L_Term a
e forall a. Num a => a -> a -> a
+ forall a. L_Term a -> Tempo
lterm_duration L_Term a
e

-- | Voice of 'L_Term'.
lterm_voice :: L_Term t -> Voice
lterm_voice :: forall t. L_Term t -> [Char]
lterm_voice ((Tempo
_,Tempo
_,[Char]
vc),Term t
_) = [Char]
vc

-- | Term of L_Term
lterm_term :: L_Term t -> Term t
lterm_term :: forall t. L_Term t -> Term t
lterm_term (L_St
_,Term t
t) = Term t
t

-- | Value of Term of L_Term
lterm_value :: L_Term t -> Maybe t
lterm_value :: forall t. L_Term t -> Maybe t
lterm_value = forall t. Term t -> Maybe t
term_value forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. L_Term t -> Term t
lterm_term

-- | Linear form of 'Bel', an ascending sequence of 'L_Term'.
type L_Bel a = [L_Term a]

-- | Linearise 'Bel' given initial 'L_St', ascending by construction.
bel_linearise :: L_St -> Bel a -> (L_Bel a,L_St)
bel_linearise :: forall a. L_St -> Bel a -> (L_Bel a, L_St)
bel_linearise L_St
l_st Bel a
b =
    let (Tempo
st,Tempo
tm,[Char]
vc) = L_St
l_st
    in case Bel a
b of
         Node Term a
e -> ([(L_St
l_st,Term a
e)],(Tempo
st forall a. Num a => a -> a -> a
+ Tempo
1forall a. Fractional a => a -> a -> a
/Tempo
tm,Tempo
tm,[Char]
vc))
         Iso Bel a
p ->
             let (L_Bel a
p',(Tempo
st',Tempo
_,[Char]
_)) = forall a. L_St -> Bel a -> (L_Bel a, L_St)
bel_linearise L_St
l_st Bel a
p
             in (L_Bel a
p',(Tempo
st',Tempo
tm,[Char]
vc))
         Seq Bel a
p Bel a
q ->
             let (L_Bel a
p',L_St
l_st') = forall a. L_St -> Bel a -> (L_Bel a, L_St)
bel_linearise L_St
l_st Bel a
p
                 (L_Bel a
q',L_St
l_st'') = forall a. L_St -> Bel a -> (L_Bel a, L_St)
bel_linearise L_St
l_st' Bel a
q
             in (L_Bel a
p' forall a. [a] -> [a] -> [a]
++ L_Bel a
q',L_St
l_st'')
         Par Par_Mode
m Bel a
p Bel a
q ->
             let (Tempo
du,Tempo
p_m,Tempo
q_m) = forall a.
Tempo -> Par_Mode -> Bel a -> Bel a -> (Tempo, Tempo, Tempo)
par_analyse Tempo
tm Par_Mode
m Bel a
p Bel a
q
                 (L_Bel a
p',L_St
_) = forall a. L_St -> Bel a -> (L_Bel a, L_St)
bel_linearise (Tempo
st,Tempo
tm forall a. Num a => a -> a -> a
* Tempo
p_m,Char
'l'forall a. a -> [a] -> [a]
:[Char]
vc) Bel a
p
                 (L_Bel a
q',L_St
_) = forall a. L_St -> Bel a -> (L_Bel a, L_St)
bel_linearise (Tempo
st,Tempo
tm forall a. Num a => a -> a -> a
* Tempo
q_m,Char
'r'forall a. a -> [a] -> [a]
:[Char]
vc) Bel a
q
             in (L_Bel a
p' forall a. L_Bel a -> L_Bel a -> L_Bel a
`lbel_merge` L_Bel a
q',(Tempo
st forall a. Num a => a -> a -> a
+ Tempo
du,Tempo
tm,[Char]
vc))
         Mul Tempo
n -> ([],(Tempo
st,Tempo
tm forall a. Num a => a -> a -> a
* Tempo
n,[Char]
vc))

-- | Merge two ascending 'L_Bel'.
lbel_merge :: L_Bel a -> L_Bel a -> L_Bel a
lbel_merge :: forall a. L_Bel a -> L_Bel a -> L_Bel a
lbel_merge = forall x a. Ord x => (a -> x) -> [a] -> [a] -> [a]
T.merge_on forall a. L_Term a -> Tempo
lterm_time

-- | Set of unique 'Tempo' at 'L_Bel'.
lbel_tempi :: L_Bel a -> [Tempo]
lbel_tempi :: forall a. L_Bel a -> [Tempo]
lbel_tempi = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\((Tempo
_,Tempo
t,[Char]
_),Term a
_) -> Tempo
t)

-- | Multiply 'Tempo' by /n/, and divide 'Time' by /n/.
lbel_tempo_mul :: Rational -> L_Bel a -> L_Bel a
lbel_tempo_mul :: forall a. Tempo -> L_Bel a -> L_Bel a
lbel_tempo_mul Tempo
n = forall a b. (a -> b) -> [a] -> [b]
map (\((Tempo
st,Tempo
tm,[Char]
vc),Term a
e) -> ((Tempo
st forall a. Fractional a => a -> a -> a
/ Tempo
n,Tempo
tm forall a. Num a => a -> a -> a
* Tempo
n,[Char]
vc),Term a
e))

{- | The multiplier that will normalise an L_Bel value.
     After normalisation all start times and durations are integral.
-}
lbel_normalise_multiplier :: L_Bel t -> Rational
lbel_normalise_multiplier :: forall t. L_Bel t -> Tempo
lbel_normalise_multiplier L_Bel t
b =
  let t :: [Tempo]
t = forall a. L_Bel a -> [Tempo]
lbel_tempi L_Bel t
b
      n :: Tempo
n = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Integral a => a -> a -> a
lcm (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ratio a -> a
denominator [Tempo]
t) forall a. Integral a => a -> a -> Ratio a
% Integer
1
      m :: Tempo
m = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Integral a => a -> a -> a
lcm (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ratio a -> a
numerator forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Tempo
n)) [Tempo]
t) forall a. Integral a => a -> a -> Ratio a
% Integer
1
  in Tempo
n forall a. Fractional a => a -> a -> a
/ Tempo
m

-- | Calculate and apply L_Bel normalisation multiplier.
lbel_normalise :: L_Bel a -> L_Bel a
lbel_normalise :: forall a. L_Bel a -> L_Bel a
lbel_normalise L_Bel a
b = forall a. Tempo -> L_Bel a -> L_Bel a
lbel_tempo_mul (forall t. L_Bel t -> Tempo
lbel_normalise_multiplier L_Bel a
b) L_Bel a
b

{- | All leftmost voices are re-written to the last non-left turning point.

> map voice_normalise ["","l","ll","lll"] == replicate 4 ""
> voice_normalise "lllrlrl" == "rlrl"
-}
voice_normalise :: Voice -> Voice
voice_normalise :: ShowS
voice_normalise = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'l')

-- | '==' 'on' 'voice_normalise'
voice_eq :: Voice -> Voice -> Bool
voice_eq :: [Char] -> [Char] -> Bool
voice_eq = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ShowS
voice_normalise

-- | Unique 'Voice's at 'L_Bel'.
lbel_voices :: L_Bel a -> [Voice]
lbel_voices :: forall a. L_Bel a -> [[Char]]
lbel_voices =
    forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b. (a -> b) -> [a] -> [b]
map (\((Tempo
_,Tempo
_,[Char]
v),Term a
_) -> ShowS
voice_normalise [Char]
v)

-- | The duration of 'L_Bel'.
lbel_duration :: L_Bel a -> Time
lbel_duration :: forall t. L_Bel t -> Tempo
lbel_duration L_Bel a
b =
    let l :: L_Bel a
l = forall a. [a] -> a
last (forall x a. Eq x => (a -> x) -> [a] -> [[a]]
T.group_on forall a. L_Term a -> Tempo
lterm_time L_Bel a
b)
    in forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map (\((Tempo
st,Tempo
tm,[Char]
_),Term a
_) -> Tempo
st forall a. Num a => a -> a -> a
+ forall a. Fractional a => a -> a
recip Tempo
tm) L_Bel a
l)

-- | Locate an 'L_Term' that is active at the indicated 'Time' and in
-- the indicated 'Voice'.
lbel_lookup :: (Time,Voice) -> L_Bel a -> Maybe (L_Term a)
lbel_lookup :: forall a. (Tempo, [Char]) -> L_Bel a -> Maybe (L_Term a)
lbel_lookup (Tempo
st,[Char]
vc) =
    let f :: (L_St, b) -> Bool
f ((Tempo
st',Tempo
tm,[Char]
vc'),b
_) = (Tempo
st forall a. Ord a => a -> a -> Bool
>= Tempo
st' Bool -> Bool -> Bool
&& Tempo
st forall a. Ord a => a -> a -> Bool
< Tempo
st' forall a. Num a => a -> a -> a
+ (Tempo
1 forall a. Fractional a => a -> a -> a
/ Tempo
tm)) Bool -> Bool -> Bool
&&
                             [Char]
vc [Char] -> [Char] -> Bool
`voice_eq` [Char]
vc'
    in forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find forall {b}. (L_St, b) -> Bool
f

-- | Calculate grid (phase diagram) for 'L_Bel'.
lbel_grid :: L_Bel a -> [[Maybe (Term a)]]
lbel_grid :: forall a. L_Bel a -> [[Maybe (Term a)]]
lbel_grid L_Bel a
l =
    let n :: L_Bel a
n = forall a. L_Bel a -> L_Bel a
lbel_normalise L_Bel a
l
        v :: [[Char]]
v = forall a. L_Bel a -> [[Char]]
lbel_voices L_Bel a
n
        d :: Tempo
d = forall t. L_Bel t -> Tempo
lbel_duration L_Bel a
n
        trs :: a -> ((a, b, c), Term a) -> Term a
trs a
st ((a
st',b
_,c
_),Term a
e) = if a
st forall a. Eq a => a -> a -> Bool
== a
st' then Term a
e else forall a. Term a
Continue
        get :: [Char] -> Tempo -> Maybe (Term a)
get [Char]
vc Tempo
st = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {b} {c} {a}. Eq a => a -> ((a, b, c), Term a) -> Term a
trs Tempo
st) (forall a. (Tempo, [Char]) -> L_Bel a -> Maybe (L_Term a)
lbel_lookup (Tempo
st,[Char]
vc) L_Bel a
n)
        f :: [Char] -> [Maybe (Term a)]
f [Char]
vc = forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Tempo -> Maybe (Term a)
get [Char]
vc) [Tempo
0 .. Tempo
d forall a. Num a => a -> a -> a
- Tempo
1]
    in forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Maybe (Term a)]
f [[Char]]
v

-- | 'lbel_grid' of 'bel_linearise'.
bel_grid :: Bel a -> [[Maybe (Term a)]]
bel_grid :: forall a. Bel a -> [[Maybe (Term a)]]
bel_grid Bel a
b =
    let (L_Bel a
l,L_St
_) = forall a. L_St -> Bel a -> (L_Bel a, L_St)
bel_linearise (Tempo
0,Tempo
1,[]) Bel a
b
    in forall a. L_Bel a -> [[Maybe (Term a)]]
lbel_grid L_Bel a
l

-- | /Bel/ type phase diagram for 'Bel' of 'Char'.  Optionally print
-- whitespace between columns.
bel_ascii :: Bool -> Bel Char -> String
bel_ascii :: Bool -> Bel Char -> [Char]
bel_ascii Bool
opt =
    let f :: Maybe (Term Char) -> Char
f Maybe (Term Char)
e = case Maybe (Term Char)
e of
                Maybe (Term Char)
Nothing -> Char
' '
                Just Term Char
Rest -> Char
'-'
                Just Term Char
Continue -> Char
'_'
                Just (Value Char
c) -> Char
c
        g :: ShowS
g = if Bool
opt then forall a. a -> [a] -> [a]
intersperse Char
' ' else forall a. a -> a
id
    in [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ShowS
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Maybe (Term Char) -> Char
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bel a -> [[Maybe (Term a)]]
bel_grid

-- | 'putStrLn' of 'bel_ascii'.
bel_ascii_pr :: Bel Char -> IO ()
bel_ascii_pr :: Bel Char -> IO ()
bel_ascii_pr = [Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bel Char -> [Char]
bel_ascii Bool
True

-- * Combinators

-- | Infix form for 'Seq'.
(~>) :: Bel a -> Bel a -> Bel a
Bel a
p ~> :: forall a. Bel a -> Bel a -> Bel a
~> Bel a
q = forall a. Bel a -> Bel a -> Bel a
Seq Bel a
p Bel a
q

{- | 'foldl1' of 'Seq'.

> lseq [Node Rest] == Node Rest
> lseq [Node Rest,Node Continue] == Seq (Node Rest) (Node Continue)
-}
lseq :: [Bel a] -> Bel a
lseq :: forall a. [Bel a] -> Bel a
lseq = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Bel a -> Bel a -> Bel a
Seq

-- | 'Node' of 'Value'.
node :: a -> Bel a
node :: forall a. a -> Bel a
node = forall a. Term a -> Bel a
Node forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Term a
Value

-- | 'lseq' of 'Node'
nseq :: [a] -> Bel a
nseq :: forall a. [a] -> Bel a
nseq = forall a. [Bel a] -> Bel a
lseq forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Bel a
node

-- | Variant of 'nseq' where @_@ is read as 'Continue' and @-@ as 'Rest'.
cseq :: String -> Bel Char
cseq :: [Char] -> Bel Char
cseq =
    let f :: Char -> Term Char
f Char
c = case Char
c of
                Char
'_' -> forall a. Term a
Continue
                Char
'-' -> forall a. Term a
Rest
                Char
_ -> forall a. a -> Term a
Value Char
c
    in forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Bel a -> Bel a -> Bel a
Seq forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Term a -> Bel a
Node forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Term Char
f)

-- | 'Par' of 'Par_Max', this is the default 'Par_Mode'.
par :: Bel a -> Bel a -> Bel a
par :: forall a. Bel a -> Bel a -> Bel a
par = forall a. Par_Mode -> Bel a -> Bel a -> Bel a
Par Par_Mode
Par_Max

-- | 'Node' of 'Rest'.
rest :: Bel a
rest :: forall a. Bel a
rest = forall a. Term a -> Bel a
Node forall a. Term a
Rest

-- | 'lseq' of 'replicate' of 'rest'.
nrests :: Integral n => n -> Bel a
nrests :: forall n a. Integral n => n -> Bel a
nrests n
n = forall a. [Bel a] -> Bel a
lseq (forall i a. Integral i => i -> a -> [a]
genericReplicate n
n forall a. Bel a
rest)

-- | Verify that 'bel_char_pp' of 'bel_char_parse' is 'id'.
bel_parse_pp_ident :: String -> Bool
bel_parse_pp_ident :: [Char] -> Bool
bel_parse_pp_ident [Char]
s = Bel Char -> [Char]
bel_char_pp ([Char] -> Bel Char
bel_char_parse [Char]
s) forall a. Eq a => a -> a -> Bool
== [Char]
s

{- | Run 'bel_char_parse', and print both 'bel_char_pp' and 'bel_ascii'.

> bel_ascii_pp "{i{ab,c[d,oh]e,sr{p,qr}},{jk,ghjkj}}"
-}
bel_ascii_pp :: String -> IO ()
bel_ascii_pp :: [Char] -> IO ()
bel_ascii_pp [Char]
s = do
  let p :: Bel Char
p = [Char] -> Bel Char
bel_char_parse [Char]
s
  [Char] -> IO ()
putStrLn (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"\nBel(R): \"",Bel Char -> [Char]
bel_char_pp Bel Char
p,[Char]
"\", Dur: ",forall a. (Show a, Integral a) => Ratio a -> [Char]
T.rational_pp (forall a. Tempo -> Bel a -> Tempo
bel_dur Tempo
1 Bel Char
p),[Char]
""])
  Bel Char -> IO ()
bel_ascii_pr Bel Char
p

-- * Parsing

-- | Parse 'Rest' 'Term'.
--
-- > P.parse p_rest "" "-"
p_rest :: T.P (Term a)
p_rest :: forall a. P (Term a)
p_rest = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall a. Term a
Rest) (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'-')

-- | Parse 'Rest' 'Term'.
--
-- > P.parse p_nrests "" "3"
p_nrests :: T.P (Bel a)
p_nrests :: forall a. P (Bel a)
p_nrests = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n a. Integral n => n -> Bel a
nrests P Integer
p_non_negative_integer

-- | Parse 'Continue' 'Term'.
--
-- > P.parse p_continue "" "_"
p_continue :: T.P (Term a)
p_continue :: forall a. P (Term a)
p_continue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall a. Term a
Continue) (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'_')

-- | Parse 'Char' 'Value' 'Term'.
--
-- > P.parse p_char_value "" "a"
p_char_value :: T.P (Term Char)
p_char_value :: P (Term Char)
p_char_value = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Term a
Value forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.lower

-- | Parse 'Char' 'Term'.
--
-- > P.parse (P.many1 p_char_term) "" "-_a"
p_char_term :: T.P (Term Char)
p_char_term :: P (Term Char)
p_char_term = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice [forall a. P (Term a)
p_rest,forall a. P (Term a)
p_continue,P (Term Char)
p_char_value]

-- | Parse 'Char' 'Node'.
--
-- > P.parse (P.many1 p_char_node) "" "-_a"
p_char_node :: T.P (Bel Char)
p_char_node :: P (Bel Char)
p_char_node = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Term a -> Bel a
Node P (Term Char)
p_char_term

-- | Parse non-negative 'Integer'.
--
-- > P.parse p_non_negative_integer "" "3"
p_non_negative_integer :: T.P Integer
p_non_negative_integer :: P Integer
p_non_negative_integer = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Read a => [Char] -> a
read (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.digit)

-- | Parse non-negative 'Rational'.
--
-- > P.parse (p_non_negative_rational `P.sepBy` (P.char ',')) "" "3%5,2/3"
p_non_negative_rational :: T.P Rational
p_non_negative_rational :: P Tempo
p_non_negative_rational = do
  Integer
n <- P Integer
p_non_negative_integer
  Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"%/"
  Integer
d <- P Integer
p_non_negative_integer
  forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
n forall a. Integral a => a -> a -> Ratio a
% Integer
d)

-- | Parse non-negative 'Double'.
--
-- > P.parse p_non_negative_double "" "3.5"
-- > P.parse (p_non_negative_double `P.sepBy` (P.char ',')) "" "3.5,7.2,1.0"
p_non_negative_double :: T.P Double
p_non_negative_double :: P Double
p_non_negative_double = do
  [Char]
a <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.digit
  Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'.'
  [Char]
b <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.digit
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => [Char] -> a
read ([Char]
a forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ [Char]
b))

-- | Parse non-negative number as 'Rational'.
--
-- > P.parse (p_non_negative_number `P.sepBy` (P.char ',')) "" "7%2,3.5,3"
p_non_negative_number :: T.P Rational
p_non_negative_number :: P Tempo
p_non_negative_number =
    forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice [forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try P Tempo
p_non_negative_rational
             ,forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Real a => a -> Tempo
toRational P Double
p_non_negative_double)
             ,forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Real a => a -> Tempo
toRational P Integer
p_non_negative_integer)]

-- | Parse 'Mul'.
--
-- > P.parse (P.many1 p_mul) "" "/3*3/2"
p_mul :: T.P (Bel a)
p_mul :: forall a. P (Bel a)
p_mul = do
  Char
op <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"*/"
  Tempo
n <- P Tempo
p_non_negative_number
  let n' :: Tempo
n' = case Char
op of
             Char
'*' -> Tempo
n
             Char
'/' -> forall a. Fractional a => a -> a
recip Tempo
n
             Char
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"p_mul"
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Tempo -> Bel a
Mul Tempo
n')

-- | Given parser for 'Bel' /a/, generate 'Iso' parser.
p_iso :: T.P (Bel a) -> T.P (Bel a)
p_iso :: forall a. P (Bel a) -> P (Bel a)
p_iso P (Bel a)
f = do
  Char
open <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"{(["
  [Bel a]
iso <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 P (Bel a)
f
  Char
close <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"})]"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ((Char, Char) -> Bool
bel_brackets_match (Char
open,Char
close))) (forall a. HasCallStack => [Char] -> a
error [Char]
"p_iso: open/close mismatch")
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Bel a -> Bel a
Iso (forall a. [Bel a] -> Bel a
lseq [Bel a]
iso))

-- | 'p_iso' of 'p_char_bel'.
--
-- > P.parse p_char_iso "" "{abcde}"
p_char_iso :: T.P (Bel Char)
p_char_iso :: P (Bel Char)
p_char_iso = forall a. P (Bel a) -> P (Bel a)
p_iso P (Bel Char)
p_char_bel

-- | Given parser for 'Bel' /a/, generate 'Par' parser.
p_par :: T.P (Bel a) -> T.P (Bel a)
p_par :: forall a. P (Bel a) -> P (Bel a)
p_par P (Bel a)
f = do
  Maybe Char
tilde <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'~')
  Char
open <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"{(["
  [[Bel a]]
items <- forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
P.sepBy (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 P (Bel a)
f) (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
',')
  Char
close <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"})]"
  let m :: Par_Mode
m = ([Char], [Char]) -> Par_Mode
par_mode_kind (forall a. Maybe a -> [a] -> [a]
T.mcons Maybe Char
tilde [Char
open], [Char
close])
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Par_Mode -> [Bel a] -> Bel a
par_of Par_Mode
m (forall a b. (a -> b) -> [a] -> [b]
map forall a. [Bel a] -> Bel a
lseq [[Bel a]]
items))

{- | 'p_par' of 'p_char_bel'.

> p = P.parse p_char_par ""
> p "{ab,{c,de}}" == p "{ab,c,de}"
> p "{ab,~(c,de)}"
-}
p_char_par :: T.P (Bel Char)
p_char_par :: P (Bel Char)
p_char_par = forall a. P (Bel a) -> P (Bel a)
p_par P (Bel Char)
p_char_bel

-- | Parse 'Bel' 'Char'.
--
-- > P.parse (P.many1 p_char_bel) "" "-_a*3"
p_char_bel :: T.P (Bel Char)
p_char_bel :: P (Bel Char)
p_char_bel = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice [forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try P (Bel Char)
p_char_par,P (Bel Char)
p_char_iso,forall a. P (Bel a)
p_mul,forall a. P (Bel a)
p_nrests,P (Bel Char)
p_char_node]

-- | Run parser for 'Bel' of 'Char'.
bel_char_parse :: String -> Bel Char
bel_char_parse :: [Char] -> Bel Char
bel_char_parse [Char]
s =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\ParseError
e -> forall a. HasCallStack => [Char] -> a
error ([Char]
"bel_parse failed\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ParseError
e))
    forall a. [Bel a] -> Bel a
lseq
    (forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
P.parse (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 P (Bel Char)
p_char_bel) [Char]
"" [Char]
s)