{-# LANGUAGE DataKinds #-}

-- |
-- Module      : Data.Rhythm.Binary.BDF
-- Description : Binary rhythm definitions
-- Copyright   : (c) Eric Bailey, 2025
--
-- License     : MIT
-- Maintainer  : eric@ericb.me
-- Stability   : stable
-- Portability : POSIX
--
-- Binary rhythm definitions, including conversion to ABC notation.
module Data.Rhythm.Binary.BDF
  ( -- * Types
    BinaryRhythmDefinition (..),
    BinaryRhythm (..),
    SomeBinaryRhythmDefinition (..),
    MIDIInstrument,

    -- * Parsing
    someBinaryRhythmDefinition,
    binaryRhythm,

    -- * Rendering
    toAbcString,
  )
where

import Closed (Closed (..))
import Control.Lens (imap)
import Data.Char (chr, ord)
import Data.Finite (Finite, getFinite)
import Data.List (intercalate, intersperse)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Proxy (Proxy (..))
import Data.Rhythm.Internal (binaryDigit)
import Data.Vector.Sized (Vector)
import Data.Vector.Sized qualified as VS
import GHC.Generics (Generic)
import GHC.TypeNats (KnownNat, Nat, SomeNat (..), natVal, someNatVal)
import Text.Printf (printf)
import Text.Trifecta (Parser, count, natural, newline, skipOptional, (<?>))

-- | A binary rhythm definition consists of a tempo and @m@ binary rhythms
-- consisting of @n@ notes each.
newtype BinaryRhythmDefinition (m :: Nat) (n :: Nat)
  = BinaryRhythmDefinition
      (Int, Vector m (BinaryRhythm n))
  deriving (BinaryRhythmDefinition m n -> BinaryRhythmDefinition m n -> Bool
(BinaryRhythmDefinition m n -> BinaryRhythmDefinition m n -> Bool)
-> (BinaryRhythmDefinition m n
    -> BinaryRhythmDefinition m n -> Bool)
-> Eq (BinaryRhythmDefinition m n)
forall (m :: Natural) (n :: Natural).
BinaryRhythmDefinition m n -> BinaryRhythmDefinition m n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (m :: Natural) (n :: Natural).
BinaryRhythmDefinition m n -> BinaryRhythmDefinition m n -> Bool
== :: BinaryRhythmDefinition m n -> BinaryRhythmDefinition m n -> Bool
$c/= :: forall (m :: Natural) (n :: Natural).
BinaryRhythmDefinition m n -> BinaryRhythmDefinition m n -> Bool
/= :: BinaryRhythmDefinition m n -> BinaryRhythmDefinition m n -> Bool
Eq, (forall x.
 BinaryRhythmDefinition m n -> Rep (BinaryRhythmDefinition m n) x)
-> (forall x.
    Rep (BinaryRhythmDefinition m n) x -> BinaryRhythmDefinition m n)
-> Generic (BinaryRhythmDefinition m n)
forall (m :: Natural) (n :: Natural) x.
Rep (BinaryRhythmDefinition m n) x -> BinaryRhythmDefinition m n
forall (m :: Natural) (n :: Natural) x.
BinaryRhythmDefinition m n -> Rep (BinaryRhythmDefinition m n) x
forall x.
Rep (BinaryRhythmDefinition m n) x -> BinaryRhythmDefinition m n
forall x.
BinaryRhythmDefinition m n -> Rep (BinaryRhythmDefinition m n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (m :: Natural) (n :: Natural) x.
BinaryRhythmDefinition m n -> Rep (BinaryRhythmDefinition m n) x
from :: forall x.
BinaryRhythmDefinition m n -> Rep (BinaryRhythmDefinition m n) x
$cto :: forall (m :: Natural) (n :: Natural) x.
Rep (BinaryRhythmDefinition m n) x -> BinaryRhythmDefinition m n
to :: forall x.
Rep (BinaryRhythmDefinition m n) x -> BinaryRhythmDefinition m n
Generic)

instance (KnownNat m, KnownNat n) => Show (BinaryRhythmDefinition m n) where
  show :: BinaryRhythmDefinition m n -> String
show (BinaryRhythmDefinition (Int
tempo, Vector m (BinaryRhythm n)
rhythms)) =
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      String
header String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (BinaryRhythm n -> String) -> [BinaryRhythm n] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map BinaryRhythm n -> String
forall a. Show a => a -> String
show (Vector m (BinaryRhythm n) -> [BinaryRhythm n]
forall (n :: Natural) a. Vector n a -> [a]
VS.toList Vector m (BinaryRhythm n)
rhythms)
    where
      header :: String
header =
        [String] -> String
unwords
          [ Int -> String
forall a. Show a => a -> String
show Int
tempo,
            Natural -> String
forall a. Show a => a -> String
show (Proxy n -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)),
            Natural -> String
forall a. Show a => a -> String
show (Proxy m -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @m))
          ]

-- | Existential wrapper around a 'BinaryRhythmDefinition' of unknown size.
data SomeBinaryRhythmDefinition where
  SomeBinaryRhythmDefinition ::
    (KnownNat m, KnownNat n) =>
    BinaryRhythmDefinition m n ->
    SomeBinaryRhythmDefinition

instance Show SomeBinaryRhythmDefinition where
  show :: SomeBinaryRhythmDefinition -> String
show (SomeBinaryRhythmDefinition BinaryRhythmDefinition m n
rhythms) = BinaryRhythmDefinition m n -> String
forall a. Show a => a -> String
show BinaryRhythmDefinition m n
rhythms

-- | A binary rhythm consists of a MIDI instrument number and a binary words of
-- length @n@, where a @1@ represents an onset.
newtype BinaryRhythm (n :: Nat) = BinaryRhythm
  {forall (n :: Natural).
BinaryRhythm n -> (MIDIInstrument, Vector n (Finite 2))
unBinaryRhythm :: (MIDIInstrument, Vector n (Finite 2))}
  deriving (BinaryRhythm n -> BinaryRhythm n -> Bool
(BinaryRhythm n -> BinaryRhythm n -> Bool)
-> (BinaryRhythm n -> BinaryRhythm n -> Bool)
-> Eq (BinaryRhythm n)
forall (n :: Natural). BinaryRhythm n -> BinaryRhythm n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (n :: Natural). BinaryRhythm n -> BinaryRhythm n -> Bool
== :: BinaryRhythm n -> BinaryRhythm n -> Bool
$c/= :: forall (n :: Natural). BinaryRhythm n -> BinaryRhythm n -> Bool
/= :: BinaryRhythm n -> BinaryRhythm n -> Bool
Eq, (forall x. BinaryRhythm n -> Rep (BinaryRhythm n) x)
-> (forall x. Rep (BinaryRhythm n) x -> BinaryRhythm n)
-> Generic (BinaryRhythm n)
forall (n :: Natural) x. Rep (BinaryRhythm n) x -> BinaryRhythm n
forall (n :: Natural) x. BinaryRhythm n -> Rep (BinaryRhythm n) x
forall x. Rep (BinaryRhythm n) x -> BinaryRhythm n
forall x. BinaryRhythm n -> Rep (BinaryRhythm n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (n :: Natural) x. BinaryRhythm n -> Rep (BinaryRhythm n) x
from :: forall x. BinaryRhythm n -> Rep (BinaryRhythm n) x
$cto :: forall (n :: Natural) x. Rep (BinaryRhythm n) x -> BinaryRhythm n
to :: forall x. Rep (BinaryRhythm n) x -> BinaryRhythm n
Generic)

instance Show (BinaryRhythm n) where
  show :: BinaryRhythm n -> String
show (BinaryRhythm (MIDIInstrument
instrumentNumber, Vector n (Finite 2)
notes)) =
    [String] -> String
unwords [MIDIInstrument -> String
forall a. Show a => a -> String
show MIDIInstrument
instrumentNumber, (Finite 2 -> String) -> Vector n (Finite 2) -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> (Finite 2 -> Integer) -> Finite 2 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite 2 -> Integer
forall (n :: Natural). Finite n -> Integer
getFinite) Vector n (Finite 2)
notes]

-- | The General MIDI Level 1 sound set consists of instruments numbered @1@
-- through @128@.
type MIDIInstrument = Closed 1 128

-- | Parse a 'BinaryRhythmDefinition' of unknown size.
someBinaryRhythmDefinition :: Parser SomeBinaryRhythmDefinition
someBinaryRhythmDefinition :: Parser SomeBinaryRhythmDefinition
someBinaryRhythmDefinition =
  do
    Int
tempo <- 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 Parser Int -> String -> Parser Int
forall a. Parser a -> String -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"tempo"
    Integer
n <- Parser Integer
forall (m :: * -> *). TokenParsing m => m Integer
natural Parser Integer -> String -> Parser Integer
forall a. Parser a -> String -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"note count"
    Int
m <- 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 Parser Int -> String -> Parser Int
forall a. Parser a -> String -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"number of rhythms"
    case (Natural -> SomeNat
someNatVal (Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n), Natural -> SomeNat
someNatVal (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m)) of
      (SomeNat (Proxy n
_ :: Proxy n), SomeNat (Proxy n
_ :: Proxy m)) ->
        do
          [BinaryRhythm n]
rhythms <- Int -> Parser (BinaryRhythm n) -> Parser [BinaryRhythm n]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
count Int
m (forall (n :: Natural). KnownNat n => Parser (BinaryRhythm n)
binaryRhythm @n)
          Parser SomeBinaryRhythmDefinition
-> (Vector n (BinaryRhythm n) -> Parser SomeBinaryRhythmDefinition)
-> Maybe (Vector n (BinaryRhythm n))
-> Parser SomeBinaryRhythmDefinition
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (String -> Parser SomeBinaryRhythmDefinition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid binary rhythm definition")
            (SomeBinaryRhythmDefinition -> Parser SomeBinaryRhythmDefinition
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeBinaryRhythmDefinition -> Parser SomeBinaryRhythmDefinition)
-> (Vector n (BinaryRhythm n) -> SomeBinaryRhythmDefinition)
-> Vector n (BinaryRhythm n)
-> Parser SomeBinaryRhythmDefinition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinaryRhythmDefinition n n -> SomeBinaryRhythmDefinition
forall (m :: Natural) (n :: Natural).
(KnownNat m, KnownNat n) =>
BinaryRhythmDefinition m n -> SomeBinaryRhythmDefinition
SomeBinaryRhythmDefinition (BinaryRhythmDefinition n n -> SomeBinaryRhythmDefinition)
-> (Vector n (BinaryRhythm n) -> BinaryRhythmDefinition n n)
-> Vector n (BinaryRhythm n)
-> SomeBinaryRhythmDefinition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Vector n (BinaryRhythm n)) -> BinaryRhythmDefinition n n
forall (m :: Natural) (n :: Natural).
(Int, Vector m (BinaryRhythm n)) -> BinaryRhythmDefinition m n
BinaryRhythmDefinition ((Int, Vector n (BinaryRhythm n)) -> BinaryRhythmDefinition n n)
-> (Vector n (BinaryRhythm n) -> (Int, Vector n (BinaryRhythm n)))
-> Vector n (BinaryRhythm n)
-> BinaryRhythmDefinition n n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
tempo,))
            (forall (n :: Natural) a. KnownNat n => [a] -> Maybe (Vector n a)
VS.fromList @m [BinaryRhythm n]
rhythms)

-- | Parse a 'BinaryRhythm' of known length.
binaryRhythm :: forall n. (KnownNat n) => Parser (BinaryRhythm n)
binaryRhythm :: forall (n :: Natural). KnownNat n => Parser (BinaryRhythm n)
binaryRhythm =
  do
    MIDIInstrument
instrumentNumber <- Integer -> MIDIInstrument
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> MIDIInstrument)
-> Parser Integer -> Parser MIDIInstrument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
forall (m :: * -> *). TokenParsing m => m Integer
natural Parser MIDIInstrument -> String -> Parser MIDIInstrument
forall a. Parser a -> String -> Parser a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"instrument number"
    [Finite 2]
notes <- Int -> Parser (Finite 2) -> Parser [Finite 2]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
count (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy n -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @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
    case [Finite 2] -> Maybe (Vector n (Finite 2))
forall (n :: Natural) a. KnownNat n => [a] -> Maybe (Vector n a)
VS.fromList [Finite 2]
notes of
      Just Vector n (Finite 2)
rhythm -> BinaryRhythm n -> Parser (BinaryRhythm n)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ((MIDIInstrument, Vector n (Finite 2)) -> BinaryRhythm n
forall (n :: Natural).
(MIDIInstrument, Vector n (Finite 2)) -> BinaryRhythm n
BinaryRhythm (MIDIInstrument
instrumentNumber, Vector n (Finite 2)
rhythm))
      Maybe (Vector n (Finite 2))
Nothing -> String -> Parser (BinaryRhythm n)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid binary rhythm definition"

-- | Given a title and a number of repeats, represent a binary rhythm definition
-- using ABC notation.
toAbcString ::
  forall m n.
  (KnownNat m, KnownNat n) =>
  String ->
  Int ->
  BinaryRhythmDefinition m n ->
  String
toAbcString :: forall (m :: Natural) (n :: Natural).
(KnownNat m, KnownNat n) =>
String -> Int -> BinaryRhythmDefinition m n -> String
toAbcString String
title Int
repeats (BinaryRhythmDefinition (Int
tempo, Vector m (BinaryRhythm n)
rhythms)) =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ String
"X: 1",
      String -> ShowS
forall r. PrintfType r => String -> r
printf String
"T: %s" String
title,
      String -> Natural -> String
forall r. PrintfType r => String -> r
printf String
"M: %d/4" (Proxy n -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)),
      String
"K: C",
      String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Q: %d" Int
tempo
    ]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Int -> BinaryRhythm n -> String) -> [BinaryRhythm n] -> [String]
forall a b. (Int -> a -> b) -> [a] -> [b]
forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap (Int -> Int -> BinaryRhythm n -> String
forall (n :: Natural). Int -> Int -> BinaryRhythm n -> String
showRhythm Int
repeats) (Vector m (BinaryRhythm n) -> [BinaryRhythm n]
forall (n :: Natural) a. Vector n a -> [a]
VS.toList Vector m (BinaryRhythm n)
rhythms)

-- | Given a number of repeats and a rhythm set index, represent a binary rhythm
-- using ABC notation.
showRhythm :: Int -> Int -> BinaryRhythm n -> String
showRhythm :: forall (n :: Natural). Int -> Int -> BinaryRhythm n -> String
showRhythm Int
repeats Int
i (BinaryRhythm (MIDIInstrument
instrumentNumber, Vector n (Finite 2)
notes)) =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
    String
"\n"
    [ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"V:%d clef=perc" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1),
      String
"L: 1/4",
      String
"%%MIDI channel 10",
      String -> Char -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%%%%MIDI drummap %c %d" Char
voiceChar (MIDIInstrument -> Integer
forall a. Integral a => a -> Integer
toInteger MIDIInstrument
instrumentNumber),
      String
tune
    ]
  where
    voiceChar :: Char
voiceChar = Int -> Char
chr (Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)

    tune :: String
tune =
      String -> ShowS
forall r. PrintfType r => String -> r
printf String
"| %s |" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"|" ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
repeats ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        (NonEmpty (Finite 2) -> String) -> [NonEmpty (Finite 2)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (Finite 2) -> String
forall {a}. (Eq a, Num a) => NonEmpty a -> String
showGroup (Vector n (Finite 2) -> [NonEmpty (Finite 2)]
forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
NE.group Vector n (Finite 2)
notes)

    showGroup :: NonEmpty a -> String
showGroup grp :: NonEmpty a
grp@(a
1 :| [a]
_) = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (NonEmpty a -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty a
grp) Char
voiceChar
    showGroup NonEmpty a
grp = Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NonEmpty a -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty a
grp)