-- Copyright 2017 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Utilities for stringed instruments.
module Derive.Call.StringUtil where
import           Prelude hiding (String)
import qualified Data.List as List
import qualified Data.Tuple as Tuple

import qualified Util.Lists as Lists
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch

import           Global


-- | TODO if Sig.Parser supported Deriver eval, I could make these return
-- String, and not need to call 'indexed_strings'.
open_strings_env :: Sig.Parser [PSignal.Pitch]
open_strings_env :: Parser [Pitch]
open_strings_env = forall a. (a -> Maybe Text) -> Parser a -> Parser a
Sig.check forall {a} {a}. IsString a => [a] -> Maybe a
non_empty forall a b. (a -> b) -> a -> b
$
    forall a deflt.
(Typecheck a, ToVal deflt) =>
Text -> deflt -> Doc -> Parser a
Sig.environ_key Text
EnvKey.open_strings ([] :: [PSignal.Pitch])
        Doc
"Pitches of open strings."
    where
    non_empty :: [a] -> Maybe a
non_empty [] = forall a. a -> Maybe a
Just a
"open-strings required"
    non_empty [a]
_ = forall a. Maybe a
Nothing

string_env :: Sig.Parser (Maybe PSignal.Pitch)
string_env :: Parser (Maybe Pitch)
string_env =
    forall a deflt.
(Typecheck a, ToVal deflt) =>
Text -> deflt -> Doc -> Parser a
Sig.environ_key Text
EnvKey.string (forall a. Maybe a
Nothing :: Maybe PSignal.Pitch)
        Doc
"Play on this string."

with_string :: String -> Derive.Deriver a -> Derive.Deriver a
with_string :: forall a. String -> Deriver a -> Deriver a
with_string = forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
EnvKey.string forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Val
str_val

insert_string :: String -> Env.Environ -> Env.Environ
insert_string :: String -> Environ -> Environ
insert_string = forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
EnvKey.string forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Val
str_val

data String = String {
    String -> Pitch
str_pitch :: !PSignal.Pitch
    , String -> NoteNumber
str_nn :: !Pitch.NoteNumber
    -- | Assign this value to EnvKey.string for this string.
    , String -> Val
str_val :: !DeriveT.Val
    } deriving (Harmonic -> String -> ShowS
[String] -> ShowS
String -> String
forall a.
(Harmonic -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [String] -> ShowS
$cshowList :: [String] -> ShowS
show :: String -> String
$cshow :: String -> String
showsPrec :: Harmonic -> String -> ShowS
$cshowsPrec :: Harmonic -> String -> ShowS
Show)

instance Pretty String where
    pretty :: String -> Text
pretty String
str = forall a. Pretty a => a -> Text
pretty (String -> Val
str_val String
str) forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (String -> Pitch
str_pitch String
str) forall a. Semigroup a => a -> a -> a
<> Text
")"

indexed_strings :: [PSignal.Pitch] -> Derive.Deriver [String]
indexed_strings :: [Pitch] -> Deriver [String]
indexed_strings [Pitch]
pitches =
    forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pitch -> Val -> Deriver String
string_val [Pitch]
pitches (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToVal a => a -> Val
Typecheck.to_val [Harmonic
0 :: Int  ..])

string :: PSignal.Pitch -> Derive.Deriver String
string :: Pitch -> Deriver String
string Pitch
pitch = Pitch -> Val -> Deriver String
string_val Pitch
pitch (forall a. ToVal a => a -> Val
Typecheck.to_val Pitch
pitch)

string_val :: PSignal.Pitch -> DeriveT.Val -> Derive.Deriver String
string_val :: Pitch -> Val -> Deriver String
string_val Pitch
pitch Val
val = do
    -- Coerce is ok because I don't want open strings in the environ to
    -- transpose.
    NoteNumber
nn <- Transposed -> Deriver NoteNumber
Pitches.pitch_nn (forall a b. RawPitch a -> RawPitch b
PSignal.coerce Pitch
pitch)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
        { str_pitch :: Pitch
str_pitch = Pitch
pitch
        , str_nn :: NoteNumber
str_nn = NoteNumber
nn
        , str_val :: Val
str_val = Val
val
        }

type Harmonic = Int

-- | If string is given, try to find this pitch in the harmonics of that
-- string.  Otherwise, find the string from open_strings which has this as
-- its lowest harmonic.
find_harmonic :: Bool -> Harmonic -> [String] -> Maybe String
    -> Pitch.NoteNumber -> Either Text (String, Harmonic)
    -- ^ Either Error (selected string, harmonic)
find_harmonic :: Bool
-> Harmonic
-> [String]
-> Maybe String
-> NoteNumber
-> Either Text (String, Harmonic)
find_harmonic Bool
h1_ok Harmonic
highest_harmonic [String]
open_strings Maybe String
maybe_string NoteNumber
nn =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Text
err) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ case Maybe String
maybe_string of
        Just String
string ->
            (String
string,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Harmonic -> NoteNumber -> NoteNumber -> Maybe Harmonic
harmonic_of Bool
h1_ok Harmonic
highest_harmonic (String -> NoteNumber
str_nn String
string) NoteNumber
nn
        Maybe String
Nothing
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
open_strings -> forall a. Maybe a
Nothing
            | Bool
otherwise -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> (b, a)
Tuple.swap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
                forall a k. (a -> Maybe k) -> [a] -> [(k, a)]
Lists.keyOnJust String -> Maybe Harmonic
harm_of [String]
open_strings
                where
                harm_of :: String -> Maybe Harmonic
harm_of String
string =
                    Bool -> Harmonic -> NoteNumber -> NoteNumber -> Maybe Harmonic
harmonic_of Bool
h1_ok Harmonic
highest_harmonic (String -> NoteNumber
str_nn String
string) NoteNumber
nn
    where
    err :: Text
err = Text
"can't find " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty NoteNumber
nn forall a. Semigroup a => a -> a -> a
<> Text
" as a natural harmonic of "
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text
"open strings: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [String]
open_strings) forall a. Pretty a => a -> Text
pretty Maybe String
maybe_string

harmonic_of :: Bool -> Harmonic -> Pitch.NoteNumber -> Pitch.NoteNumber
    -> Maybe Harmonic
harmonic_of :: Bool -> Harmonic -> NoteNumber -> NoteNumber -> Maybe Harmonic
harmonic_of Bool
h1_ok Harmonic
limit NoteNumber
base NoteNumber
pitch =
    (Harmonic
start+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> Maybe Harmonic
List.findIndex (NoteNumber -> Hz -> Bool
close NoteNumber
pitch) [Hz]
harmonics
    where
    start :: Harmonic
start = if Bool
h1_ok then Harmonic
1 else Harmonic
2
    harmonics :: [Hz]
harmonics = forall a. Harmonic -> [a] -> [a]
take Harmonic
limit forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map ((NoteNumber -> Hz
Pitch.nn_to_hz NoteNumber
base *) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Harmonic
start..]
    close :: NoteNumber -> Hz -> Bool
close NoteNumber
nn Hz
hz = Harmonic -> NoteNumber -> NoteNumber -> Bool
Pitch.nns_close Harmonic
50 NoteNumber
nn (Hz -> NoteNumber
Pitch.hz_to_nn Hz
hz)