{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : Data.Rhythm.BDF
-- Copyright   : (c) Eric Bailey, 2025
--
-- License     : MIT
-- Maintainer  : eric@ericb.me
-- Stability   : experimental
-- Portability : POSIX
--
-- Binary rhythm definitions, including conversion to ABC notation.
module Data.Rhythm.BDF
  ( BinaryRhythmDefinition (..),
    BinaryRhythm (..),
    binaryRhythmDefinition,
    toAbcString,
  )
where

import Control.Applicative ((<|>))
import Data.Char (chr, ord)
import Data.Finite (Finite, getFinite)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Text.Printf (printf)
import Text.Trifecta (Parser, char, count, natural, newline, skipOptional, (<?>))

-- | A binary rhythm definition consists of a tempo, a note count \(n\), a
-- rhythm count \(m\), and a list of \(m\) binary rhythms consisting of \(n\)
-- notes.
data BinaryRhythmDefinition = BinaryRhythmDefinition
  { -- | beats per minute
    BinaryRhythmDefinition -> Int
tempo :: !Int,
    -- | number of notes in each rhythm
    BinaryRhythmDefinition -> Int
noteCount :: !Int,
    -- | number of rhythms
    BinaryRhythmDefinition -> Int
rhythmCount :: !Int,
    -- | a list of binary rhythms
    BinaryRhythmDefinition -> [BinaryRhythm]
rhythms :: ![BinaryRhythm]
  }
  deriving (BinaryRhythmDefinition -> BinaryRhythmDefinition -> Bool
(BinaryRhythmDefinition -> BinaryRhythmDefinition -> Bool)
-> (BinaryRhythmDefinition -> BinaryRhythmDefinition -> Bool)
-> Eq BinaryRhythmDefinition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BinaryRhythmDefinition -> BinaryRhythmDefinition -> Bool
== :: BinaryRhythmDefinition -> BinaryRhythmDefinition -> Bool
$c/= :: BinaryRhythmDefinition -> BinaryRhythmDefinition -> Bool
/= :: BinaryRhythmDefinition -> BinaryRhythmDefinition -> Bool
Eq)

instance Show BinaryRhythmDefinition where
  show :: BinaryRhythmDefinition -> [Char]
show (BinaryRhythmDefinition {Int
[BinaryRhythm]
tempo :: BinaryRhythmDefinition -> Int
noteCount :: BinaryRhythmDefinition -> Int
rhythmCount :: BinaryRhythmDefinition -> Int
rhythms :: BinaryRhythmDefinition -> [BinaryRhythm]
tempo :: Int
noteCount :: Int
rhythmCount :: Int
rhythms :: [BinaryRhythm]
..}) =
    [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [[Char]] -> [Char]
unwords ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show [Int
tempo, Int
noteCount, Int
rhythmCount]) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (BinaryRhythm -> [Char]) -> [BinaryRhythm] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map BinaryRhythm -> [Char]
forall a. Show a => a -> [Char]
show [BinaryRhythm]
rhythms

-- | A binary rhythm consists of a MIDI instrument number and a list of binary
-- words where a @1@ represents an onset.
data BinaryRhythm = BinaryRhythm
  { -- | MIDI instrument number
    BinaryRhythm -> Int
instrumentNumber :: !Int,
    -- | a list of zeros and ones
    BinaryRhythm -> [Finite 2]
notes :: ![Finite 2]
  }
  deriving (BinaryRhythm -> BinaryRhythm -> Bool
(BinaryRhythm -> BinaryRhythm -> Bool)
-> (BinaryRhythm -> BinaryRhythm -> Bool) -> Eq BinaryRhythm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BinaryRhythm -> BinaryRhythm -> Bool
== :: BinaryRhythm -> BinaryRhythm -> Bool
$c/= :: BinaryRhythm -> BinaryRhythm -> Bool
/= :: BinaryRhythm -> BinaryRhythm -> Bool
Eq)

instance Show BinaryRhythm where
  show :: BinaryRhythm -> [Char]
show (BinaryRhythm {Int
[Finite 2]
instrumentNumber :: BinaryRhythm -> Int
notes :: BinaryRhythm -> [Finite 2]
instrumentNumber :: Int
notes :: [Finite 2]
..}) =
    [[Char]] -> [Char]
unwords [Int -> [Char]
forall a. Show a => a -> [Char]
show Int
instrumentNumber, (Finite 2 -> [Char]) -> [Finite 2] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Integer -> [Char]
forall a. Show a => a -> [Char]
show (Integer -> [Char]) -> (Finite 2 -> Integer) -> Finite 2 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite 2 -> Integer
forall (n :: Nat). Finite n -> Integer
getFinite) [Finite 2]
notes]

-- | Parse a binary rhythm definition.
binaryRhythmDefinition :: Parser BinaryRhythmDefinition
binaryRhythmDefinition :: Parser BinaryRhythmDefinition
binaryRhythmDefinition =
  do
    Int
theTempo <- Parser Int
posInt Parser Int -> [Char] -> Parser Int
forall a. Parser a -> [Char] -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> [Char] -> m a
<?> [Char]
"tempo"
    Int
theNoteCount <- Parser Int
posInt Parser Int -> [Char] -> Parser Int
forall a. Parser a -> [Char] -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> [Char] -> m a
<?> [Char]
"note count"
    Int
theRhythmCount <- Parser Int
posInt Parser Int -> [Char] -> Parser Int
forall a. Parser a -> [Char] -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> [Char] -> m a
<?> [Char]
"number of rhythms"
    [BinaryRhythm]
theRhythms <- Int -> Parser BinaryRhythm -> Parser [BinaryRhythm]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
count Int
theRhythmCount (Int -> Parser BinaryRhythm
binaryRhythm Int
theNoteCount)
    BinaryRhythmDefinition -> Parser BinaryRhythmDefinition
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BinaryRhythmDefinition -> Parser BinaryRhythmDefinition)
-> BinaryRhythmDefinition -> Parser BinaryRhythmDefinition
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> [BinaryRhythm] -> BinaryRhythmDefinition
BinaryRhythmDefinition Int
theTempo Int
theNoteCount Int
theRhythmCount [BinaryRhythm]
theRhythms

-- | Given a title and a number of repeats, represent a binary rhythm definition
-- using ABC notation.
toAbcString :: String -> Int -> BinaryRhythmDefinition -> String
toAbcString :: [Char] -> Int -> BinaryRhythmDefinition -> [Char]
toAbcString [Char]
title Int
repeats (BinaryRhythmDefinition {Int
[BinaryRhythm]
tempo :: BinaryRhythmDefinition -> Int
noteCount :: BinaryRhythmDefinition -> Int
rhythmCount :: BinaryRhythmDefinition -> Int
rhythms :: BinaryRhythmDefinition -> [BinaryRhythm]
tempo :: Int
noteCount :: Int
rhythmCount :: Int
rhythms :: [BinaryRhythm]
..}) =
  [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
    [Char]
"X: 1"
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"T: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
title
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"M: %d/4" Int
noteCount
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"K: C"
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"Q: %d" Int
tempo
      [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Int -> BinaryRhythm -> [Char])
-> [Int] -> [BinaryRhythm] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> BinaryRhythm -> [Char]
showRhythm [Int
0 :: Int ..] [BinaryRhythm]
rhythms
  where
    showRhythm :: Int -> BinaryRhythm -> [Char]
showRhythm Int
i (BinaryRhythm {Int
[Finite 2]
instrumentNumber :: BinaryRhythm -> Int
notes :: BinaryRhythm -> [Finite 2]
instrumentNumber :: Int
notes :: [Finite 2]
..}) =
      [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate
        [Char]
"\n"
        [ [Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"V:%d clef=perc" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1),
          [Char]
"L: 1/4",
          [Char]
"%%MIDI channel 10",
          [Char] -> Char -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%%%%MIDI drummap %c %d" Char
c Int
instrumentNumber,
          [Char]
tune
        ]
      where
        c :: Char
c = Int -> Char
chr (Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)
        tune :: [Char]
tune =
          ([Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" |") ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
            [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
              Int -> [Char] -> [[Char]]
forall a. Int -> a -> [a]
replicate Int
repeats ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
                [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"| %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                  ((NonEmpty (Finite 2) -> [Char])
 -> [NonEmpty (Finite 2)] -> [Char])
-> [NonEmpty (Finite 2)]
-> (NonEmpty (Finite 2) -> [Char])
-> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (NonEmpty (Finite 2) -> [Char]) -> [NonEmpty (Finite 2)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Finite 2] -> [NonEmpty (Finite 2)]
forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
NE.group [Finite 2]
notes) ((NonEmpty (Finite 2) -> [Char]) -> [Char])
-> (NonEmpty (Finite 2) -> [Char]) -> [Char]
forall a b. (a -> b) -> a -> b
$ \grp :: NonEmpty (Finite 2)
grp@(Finite 2
digit :| [Finite 2]
_) ->
                    if Finite 2
1 Finite 2 -> Finite 2 -> Bool
forall a. Eq a => a -> a -> Bool
== Finite 2
digit
                      then Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (NonEmpty (Finite 2) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (Finite 2)
grp) Char
c
                      else Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NonEmpty (Finite 2) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (Finite 2)
grp)

binaryRhythm :: Int -> Parser BinaryRhythm
binaryRhythm :: Int -> Parser BinaryRhythm
binaryRhythm Int
n =
  do
    Int
theInstrumentNumber <- Parser Int
posInt Parser Int -> [Char] -> Parser Int
forall a. Parser a -> [Char] -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> [Char] -> m a
<?> [Char]
"instrument number"
    [Finite 2]
theRhythm <- Int -> Parser (Finite 2) -> Parser [Finite 2]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
count Int
n Parser (Finite 2)
binaryDigit
    Parser Char -> Parser ()
forall (m :: * -> *) a. Alternative m => m a -> m ()
skipOptional Parser Char
forall (m :: * -> *). CharParsing m => m Char
newline
    BinaryRhythm -> Parser BinaryRhythm
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BinaryRhythm -> Parser BinaryRhythm)
-> BinaryRhythm -> Parser BinaryRhythm
forall a b. (a -> b) -> a -> b
$ Int -> [Finite 2] -> BinaryRhythm
BinaryRhythm Int
theInstrumentNumber [Finite 2]
theRhythm

binaryDigit :: Parser (Finite 2)
binaryDigit :: Parser (Finite 2)
binaryDigit = Parser (Finite 2)
zero Parser (Finite 2) -> Parser (Finite 2) -> Parser (Finite 2)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Finite 2)
one
  where
    zero :: Parser (Finite 2)
zero = (Finite 2
0 Finite 2 -> Parser Char -> Parser (Finite 2)
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'0') Parser (Finite 2) -> [Char] -> Parser (Finite 2)
forall a. Parser a -> [Char] -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> [Char] -> m a
<?> [Char]
"zero"
    one :: Parser (Finite 2)
one = (Finite 2
1 Finite 2 -> Parser Char -> Parser (Finite 2)
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'1') Parser (Finite 2) -> [Char] -> Parser (Finite 2)
forall a. Parser a -> [Char] -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> [Char] -> m a
<?> [Char]
"one"

posInt :: Parser Int
posInt :: Parser Int
posInt = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
forall (m :: * -> *). TokenParsing m => m Integer
natural