-- Copyright 2013 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

{- | A common library of attributes for instrument definitians.

    Usually attributes act like tags in that they all get combined into one
    'Attributes' set.  This makes sense in some cases, but not all.  For
    example, @+mute@ and @+cresc@ can be usefully combined, you could imagine
    applying @+mute@ to the entire melody and wanting that to combine with
    individual articulations within.  But @+pizz-right@ is an articulation on
    its own, and it doesn't really make sense to, e.g. put @+right@ on melody
    by itself.

    And of course since attributes are all mashed into one set, the information
    about which ones were applied together is lost.  For example, I think it's
    impossible for the lilypond backend to figure how to notate @+pizz+right@
    inside of @+pizz@ since right-hand pizz is applied as a per-note
    articulation, while plain pizz is a mode.  But it's trivial if the
    attribute is @+pizz-right@ instead.
-}
module Derive.Attrs where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Aeson as Aeson
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Serialize as Serialize
import qualified Derive.ShowVal as ShowVal
import Global


-- | Instruments can have a set of attributes along with them.  These are
-- propagated dynamically down the derivation stack.  They function like
-- arguments to an instrument, and will typically select an articulation, or
-- a drum from a drumset, or something like that.
type Attribute = Text

newtype Attributes = Attributes (Set Attribute)
    deriving (NonEmpty Attributes -> Attributes
Attributes -> Attributes -> Attributes
(Attributes -> Attributes -> Attributes)
-> (NonEmpty Attributes -> Attributes)
-> (forall b. Integral b => b -> Attributes -> Attributes)
-> Semigroup Attributes
forall b. Integral b => b -> Attributes -> Attributes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Attributes -> Attributes
$cstimes :: forall b. Integral b => b -> Attributes -> Attributes
sconcat :: NonEmpty Attributes -> Attributes
$csconcat :: NonEmpty Attributes -> Attributes
<> :: Attributes -> Attributes -> Attributes
$c<> :: Attributes -> Attributes -> Attributes
Semigroup, Semigroup Attributes
Attributes
Semigroup Attributes
-> Attributes
-> (Attributes -> Attributes -> Attributes)
-> ([Attributes] -> Attributes)
-> Monoid Attributes
[Attributes] -> Attributes
Attributes -> Attributes -> Attributes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Attributes] -> Attributes
$cmconcat :: [Attributes] -> Attributes
mappend :: Attributes -> Attributes -> Attributes
$cmappend :: Attributes -> Attributes -> Attributes
mempty :: Attributes
$cmempty :: Attributes
Monoid, Attributes -> Attributes -> Bool
(Attributes -> Attributes -> Bool)
-> (Attributes -> Attributes -> Bool) -> Eq Attributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attributes -> Attributes -> Bool
$c/= :: Attributes -> Attributes -> Bool
== :: Attributes -> Attributes -> Bool
$c== :: Attributes -> Attributes -> Bool
Eq, Eq Attributes
Eq Attributes
-> (Attributes -> Attributes -> Ordering)
-> (Attributes -> Attributes -> Bool)
-> (Attributes -> Attributes -> Bool)
-> (Attributes -> Attributes -> Bool)
-> (Attributes -> Attributes -> Bool)
-> (Attributes -> Attributes -> Attributes)
-> (Attributes -> Attributes -> Attributes)
-> Ord Attributes
Attributes -> Attributes -> Bool
Attributes -> Attributes -> Ordering
Attributes -> Attributes -> Attributes
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Attributes -> Attributes -> Attributes
$cmin :: Attributes -> Attributes -> Attributes
max :: Attributes -> Attributes -> Attributes
$cmax :: Attributes -> Attributes -> Attributes
>= :: Attributes -> Attributes -> Bool
$c>= :: Attributes -> Attributes -> Bool
> :: Attributes -> Attributes -> Bool
$c> :: Attributes -> Attributes -> Bool
<= :: Attributes -> Attributes -> Bool
$c<= :: Attributes -> Attributes -> Bool
< :: Attributes -> Attributes -> Bool
$c< :: Attributes -> Attributes -> Bool
compare :: Attributes -> Attributes -> Ordering
$ccompare :: Attributes -> Attributes -> Ordering
Ord, ReadPrec [Attributes]
ReadPrec Attributes
Int -> ReadS Attributes
ReadS [Attributes]
(Int -> ReadS Attributes)
-> ReadS [Attributes]
-> ReadPrec Attributes
-> ReadPrec [Attributes]
-> Read Attributes
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Attributes]
$creadListPrec :: ReadPrec [Attributes]
readPrec :: ReadPrec Attributes
$creadPrec :: ReadPrec Attributes
readList :: ReadS [Attributes]
$creadList :: ReadS [Attributes]
readsPrec :: Int -> ReadS Attributes
$creadsPrec :: Int -> ReadS Attributes
Read, Int -> Attributes -> ShowS
[Attributes] -> ShowS
Attributes -> String
(Int -> Attributes -> ShowS)
-> (Attributes -> String)
-> ([Attributes] -> ShowS)
-> Show Attributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attributes] -> ShowS
$cshowList :: [Attributes] -> ShowS
show :: Attributes -> String
$cshow :: Attributes -> String
showsPrec :: Int -> Attributes -> ShowS
$cshowsPrec :: Int -> Attributes -> ShowS
Show, Get Attributes
Putter Attributes
Putter Attributes -> Get Attributes -> Serialize Attributes
forall a. Putter a -> Get a -> Serialize a
get :: Get Attributes
$cget :: Get Attributes
put :: Putter Attributes
$cput :: Putter Attributes
Serialize.Serialize,
        Attributes -> ()
(Attributes -> ()) -> NFData Attributes
forall a. (a -> ()) -> NFData a
rnf :: Attributes -> ()
$crnf :: Attributes -> ()
DeepSeq.NFData, [Attributes] -> Encoding
[Attributes] -> Value
Attributes -> Encoding
Attributes -> Value
(Attributes -> Value)
-> (Attributes -> Encoding)
-> ([Attributes] -> Value)
-> ([Attributes] -> Encoding)
-> ToJSON Attributes
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Attributes] -> Encoding
$ctoEncodingList :: [Attributes] -> Encoding
toJSONList :: [Attributes] -> Value
$ctoJSONList :: [Attributes] -> Value
toEncoding :: Attributes -> Encoding
$ctoEncoding :: Attributes -> Encoding
toJSON :: Attributes -> Value
$ctoJSON :: Attributes -> Value
Aeson.ToJSON, Value -> Parser [Attributes]
Value -> Parser Attributes
(Value -> Parser Attributes)
-> (Value -> Parser [Attributes]) -> FromJSON Attributes
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Attributes]
$cparseJSONList :: Value -> Parser [Attributes]
parseJSON :: Value -> Parser Attributes
$cparseJSON :: Value -> Parser Attributes
Aeson.FromJSON)

instance Pretty Attributes where pretty :: Attributes -> Attribute
pretty = Attributes -> Attribute
forall a. ShowVal a => a -> Attribute
ShowVal.show_val
instance ShowVal.ShowVal Attributes where
    show_val :: Attributes -> Attribute
show_val = (Attribute
"+"<>) (Attribute -> Attribute)
-> (Attributes -> Attribute) -> Attributes -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute -> [Attribute] -> Attribute
Text.intercalate Attribute
"+" ([Attribute] -> Attribute)
-> (Attributes -> [Attribute]) -> Attributes -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> [Attribute]
to_list

attr :: Text -> Attributes
attr :: Attribute -> Attributes
attr = Set Attribute -> Attributes
Attributes (Set Attribute -> Attributes)
-> (Attribute -> Set Attribute) -> Attribute -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute -> Set Attribute
forall a. a -> Set a
Set.singleton

attrs :: [Text] -> Attributes
attrs :: [Attribute] -> Attributes
attrs = Set Attribute -> Attributes
Attributes (Set Attribute -> Attributes)
-> ([Attribute] -> Set Attribute) -> [Attribute] -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attribute] -> Set Attribute
forall a. Ord a => [a] -> Set a
Set.fromList

to_set :: Attributes -> Set Attribute
to_set :: Attributes -> Set Attribute
to_set (Attributes Set Attribute
attrs) = Set Attribute
attrs

to_list :: Attributes -> [Attribute]
to_list :: Attributes -> [Attribute]
to_list = Set Attribute -> [Attribute]
forall a. Set a -> [a]
Set.toList (Set Attribute -> [Attribute])
-> (Attributes -> Set Attribute) -> Attributes -> [Attribute]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Set Attribute
to_set

difference :: Attributes -> Attributes -> Attributes
difference :: Attributes -> Attributes -> Attributes
difference (Attributes Set Attribute
x) (Attributes Set Attribute
y) = Set Attribute -> Attributes
Attributes (Set Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Attribute
x Set Attribute
y)

intersection :: Attributes -> Attributes -> Attributes
intersection :: Attributes -> Attributes -> Attributes
intersection (Attributes Set Attribute
x) (Attributes Set Attribute
y) = Set Attribute -> Attributes
Attributes (Set Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Attribute
x Set Attribute
y)

-- | True if the first argument contains the attributes in the second.
contain :: Attributes -> Attributes -> Bool
contain :: Attributes -> Attributes -> Bool
contain (Attributes Set Attribute
super) (Attributes Set Attribute
sub) = Set Attribute
sub Set Attribute -> Set Attribute -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Attribute
super

-- | Remove the attributes in the first argument from the second.
remove :: Attributes -> Attributes -> Attributes
remove :: Attributes -> Attributes -> Attributes
remove (Attributes Set Attribute
remove) (Attributes Set Attribute
attrs) =
    Set Attribute -> Attributes
Attributes (Set Attribute -> Attributes) -> Set Attribute -> Attributes
forall a b. (a -> b) -> a -> b
$ Set Attribute
attrs Set Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Attribute
remove


-- * articulations

flaut :: Attributes
flaut = Attribute -> Attributes
attr Attribute
"flaut" -- flautando
staccato :: Attributes
staccato = Attribute -> Attributes
attr Attribute
"stac"
spiccato :: Attributes
spiccato = Attribute -> Attributes
attr Attribute
"spic"
detache :: Attributes
detache = Attribute -> Attributes
attr Attribute
"det"
marcato :: Attributes
marcato = Attribute -> Attributes
attr Attribute
"marc"
portato :: Attributes
portato = Attribute -> Attributes
attr Attribute
"port"
tenuto :: Attributes
tenuto = Attribute -> Attributes
attr Attribute
"tenuto"
accent :: Attributes
accent = Attribute -> Attributes
attr Attribute
"accent"
espr :: Attributes
espr = Attribute -> Attributes
attr Attribute
"espr" -- espressivo
trill :: Attributes
trill = Attribute -> Attributes
attr Attribute
"trill"
trem :: Attributes
trem = Attribute -> Attributes
attr Attribute
"trem" -- tremolo
arpeggio :: Attributes
arpeggio = Attribute -> Attributes
attr Attribute
"arp"
legato :: Attributes
legato = Attribute -> Attributes
attr Attribute
"legato"
porta :: Attributes
porta = Attribute -> Attributes
attr Attribute
"porta" -- portamento
gliss :: Attributes
gliss = Attribute -> Attributes
attr Attribute
"gliss" -- glissando
mute :: Attributes
mute = Attribute -> Attributes
attr Attribute
"mute" -- generic muted note

vib :: Attributes
vib = Attribute -> Attributes
attr Attribute
"vib" -- vibrato
nv :: Attributes
nv = Attribute -> Attributes
attr Attribute
"nv" -- no vibrato

-- * dynamics

cresc :: Attributes
cresc = Attribute -> Attributes
attr Attribute
"cresc"
dim :: Attributes
dim = Attribute -> Attributes
attr Attribute
"dim" -- either diminuendo, or diminished
sfz :: Attributes
sfz = Attribute -> Attributes
attr Attribute
"sfz"
sffz :: Attributes
sffz = Attribute -> Attributes
attr Attribute
"sffz"
fp :: Attributes
fp = Attribute -> Attributes
attr Attribute
"fp"
pfp :: Attributes
pfp = Attribute -> Attributes
attr Attribute
"pfp"
fpf :: Attributes
fpf = Attribute -> Attributes
attr Attribute
"fpf"
soft :: Attributes
soft = Attribute -> Attributes
attr Attribute
"soft"
loud :: Attributes
loud = Attribute -> Attributes
attr Attribute
"loud"

-- Whole note and half note variants, e.g. for trills.
half :: Attributes
half = Attribute -> Attributes
attr Attribute
"half"
whole :: Attributes
whole = Attribute -> Attributes
attr Attribute
"whole"

-- * strings

arco :: Attributes
arco = Attribute -> Attributes
attr Attribute
"arco"
pizz :: Attributes
pizz = Attribute -> Attributes
attr Attribute
"pizz" -- pizzicato
pizz_right :: Attributes
pizz_right = Attribute -> Attributes
attr Attribute
"pizz-right"
snap :: Attributes
snap = Attribute -> Attributes
attr Attribute
"snap" -- snap pizz, aka Bartok pizz
harm :: Attributes
harm = Attribute -> Attributes
attr Attribute
"harm"
legno :: Attributes
legno = Attribute -> Attributes
attr Attribute
"legno"
sord :: Attributes
sord = Attribute -> Attributes
attr Attribute
"sord" -- con sordino

-- Artificial or natural, presumably for harmonics.
natural :: Attributes
natural = Attribute -> Attributes
attr Attribute
"nat"
artificial :: Attributes
artificial = Attribute -> Attributes
attr Attribute
"art"

pont :: Attributes
pont = Attribute -> Attributes
attr Attribute
"pont" -- ponticello
tasto :: Attributes
tasto = Attribute -> Attributes
attr Attribute
"tasto" -- sul tasto

bisbig :: Attributes
bisbig = Attribute -> Attributes
attr Attribute
"bisbig" -- bisbigliando

-- * winds

flutter :: Attributes
flutter = Attribute -> Attributes
attr Attribute
"flutter"

-- * drums

snare :: Attributes
snare = Attribute -> Attributes
attr Attribute
"snare" -- snare
stick :: Attributes
stick = Attribute -> Attributes
attr Attribute
"stick"
bd :: Attributes
bd = Attribute -> Attributes
attr Attribute
"bd" -- base drum
hh :: Attributes
hh = Attribute -> Attributes
attr Attribute
"hh" -- high-hat
crash :: Attributes
crash = Attribute -> Attributes
attr Attribute
"crash" -- crash cymbal
ride :: Attributes
ride = Attribute -> Attributes
attr Attribute
"ride" -- ride cymbal
tom :: Attributes
tom = Attribute -> Attributes
attr Attribute
"tom"

pedal :: Attributes
pedal = Attribute -> Attributes
attr Attribute
"pedal"

-- ** technique

left :: Attributes
left = Attribute -> Attributes
attr Attribute
"left" -- played with left hand
right :: Attributes
right = Attribute -> Attributes
attr Attribute
"right" -- played with right hand
thumb :: Attributes
thumb = Attribute -> Attributes
attr Attribute
"thumb"

center :: Attributes
center = Attribute -> Attributes
attr Attribute
"center"
edge :: Attributes
edge = Attribute -> Attributes
attr Attribute
"edge"
slap :: Attributes
slap = Attribute -> Attributes
attr Attribute
"slap"
knuckle :: Attributes
knuckle = Attribute -> Attributes
attr Attribute
"knuckle"
rim :: Attributes
rim = Attribute -> Attributes
attr Attribute
"rim"
damp :: Attributes
damp = Attribute -> Attributes
attr Attribute
"damp"

open :: Attributes
open = Attribute -> Attributes
attr Attribute
"open"
closed :: Attributes
closed = Attribute -> Attributes
attr Attribute
"closed"

low :: Attributes
low = Attribute -> Attributes
attr Attribute
"low"
middle :: Attributes
middle = Attribute -> Attributes
attr Attribute
"middle"
high :: Attributes
high = Attribute -> Attributes
attr Attribute
"high"

up :: Attributes
up = Attribute -> Attributes
attr Attribute
"up"
down :: Attributes
down = Attribute -> Attributes
attr Attribute
"down"

short :: Attributes
short = Attribute -> Attributes
attr Attribute
"short"
long :: Attributes
long = Attribute -> Attributes
attr Attribute
"long"

fast :: Attributes
fast = Attribute -> Attributes
attr Attribute
"fast"
medium :: Attributes
medium = Attribute -> Attributes
attr Attribute
"medium"
slow :: Attributes
slow = Attribute -> Attributes
attr Attribute
"slow"

light :: Attributes
light = Attribute -> Attributes
attr Attribute
"light"
heavy :: Attributes
heavy = Attribute -> Attributes
attr Attribute
"heavy"

loose :: Attributes
loose = Attribute -> Attributes
attr Attribute
"loose"
tight :: Attributes
tight = Attribute -> Attributes
attr Attribute
"tight"

dry :: Attributes
dry = Attribute -> Attributes
attr Attribute
"dry"
wet :: Attributes
wet = Attribute -> Attributes
attr Attribute
"wet"

-- * misc

-- Many of these attributes are meant to be combined with others.

-- | Generic variations.  E.g. if there are two snares you can have
-- @snare \<> v1@ and @snare \<> v2@.
v1 :: Attributes
v1 = Attribute -> Attributes
attr Attribute
"v1"
v2 :: Attributes
v2 = Attribute -> Attributes
attr Attribute
"v2"
v3 :: Attributes
v3 = Attribute -> Attributes
attr Attribute
"v3"
v4 :: Attributes
v4 = Attribute -> Attributes
attr Attribute
"v4"
v5 :: Attributes
v5 = Attribute -> Attributes
attr Attribute
"v5"
v6 :: Attributes
v6 = Attribute -> Attributes
attr Attribute
"v6"

-- | Ordinal numbers, either for intervals, or for the nth of something (e.g.
-- harm <> third).
first :: Attributes
first = Attribute -> Attributes
attr Attribute
"first"
second :: Attributes
second = Attribute -> Attributes
attr Attribute
"second"
third :: Attributes
third = Attribute -> Attributes
attr Attribute
"third"
fourth :: Attributes
fourth = Attribute -> Attributes
attr Attribute
"fourth"
fifth :: Attributes
fifth = Attribute -> Attributes
attr Attribute
"fifth"
sixth :: Attributes
sixth = Attribute -> Attributes
attr Attribute
"sixth"
seventh :: Attributes
seventh = Attribute -> Attributes
attr Attribute
"seventh"