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

-- | The 'Note' type and support.
module Synth.Shared.Note where
import qualified Crypto.Hash.MD5 as MD5
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Base64.URL as Base64.URL
import qualified Data.ByteString.Char8 as ByteString.Char8
import qualified Data.ByteString.Lazy as ByteString.Lazy
import qualified Data.Map.Strict as Map

import qualified Util.Pretty as Pretty
import qualified Util.Serialize as Serialize
import           Util.Serialize (get, put)

import qualified Derive.Attrs as Attrs
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Perform.Pitch as Pitch
import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Signal as Signal
import qualified Ui.Id as Id

import           Global
import           Synth.Types


-- | IR for im.  These are the inputs for im synthesizers.
data Note = Note {
    -- | Map this note to one of the synthesizer's patches.
    Note -> Element
patch :: !PatchName
    -- | Unique name for this particular instantiation of the patch.
    , Note -> Instrument
instrument :: !ScoreT.Instrument
    -- | Display render progress on this track.
    --
    -- Previously, I inferred the track from the instrument, but that runs into
    -- trouble when there isn't a 1:1 mapping from track to instrument.
    , Note -> Maybe TrackId
trackId :: !(Maybe Id.TrackId)
    -- | Address this note to a particular element within the patch.  What it
    -- is depends on the instrument.  For instance, it might the a particular
    -- string on a pipa.  The difference from 'attributes' is that each element
    -- is mutually exclusive.
    , Note -> Element
element :: !Element
    , Note -> RealTime
start :: !RealTime
    , Note -> RealTime
duration :: !RealTime
    -- | E.g. envelope, pitch, lpf.
    , Note -> Map Control Signal
controls :: !(Map Control.Control Signal.Signal)
    , Note -> Attributes
attributes :: !Attrs.Attributes
    -- | The stack of the score event that generated this Note.  For errors.
    , Note -> Stack
stack :: Stack.Stack
    } deriving (Note -> Note -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note -> Note -> Bool
$c/= :: Note -> Note -> Bool
== :: Note -> Note -> Bool
$c== :: Note -> Note -> Bool
Eq, Int -> Note -> ShowS
[Note] -> ShowS
Note -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note] -> ShowS
$cshowList :: [Note] -> ShowS
show :: Note -> String
$cshow :: Note -> String
showsPrec :: Int -> Note -> ShowS
$cshowsPrec :: Int -> Note -> ShowS
Show)

type Element = Text

-- | Unique identifier for a patch.
type PatchName = Text

end :: Note -> RealTime
end :: Note -> RealTime
end Note
n = Note -> RealTime
start Note
n forall a. Num a => a -> a -> a
+ Note -> RealTime
duration Note
n

instance Serialize.Serialize Note where
    put :: Putter Note
put (Note Element
a Instrument
b Maybe TrackId
c Element
d RealTime
e RealTime
f Map Control Signal
g Attributes
h Stack
i) =
        forall a. Serialize a => Putter a
put Element
a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Serialize a => Putter a
put Instrument
b forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Serialize a => Putter a
put Maybe TrackId
c forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Serialize a => Putter a
put Element
d forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Serialize a => Putter a
put RealTime
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Serialize a => Putter a
put RealTime
f forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Serialize a => Putter a
put Map Control Signal
g forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Serialize a => Putter a
put Attributes
h
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Serialize a => Putter a
put Stack
i
    get :: Get Note
get = Element
-> Instrument
-> Maybe TrackId
-> Element
-> RealTime
-> RealTime
-> Map Control Signal
-> Attributes
-> Stack
-> Note
Note forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get

instance Pretty Note where
    format :: Note -> Doc
format (Note Element
patch Instrument
inst Maybe TrackId
trackId Element
element RealTime
start RealTime
dur Map Control Signal
controls Attributes
attrs Stack
stack) =
        Doc -> [(Element, Doc)] -> Doc
Pretty.record Doc
"Note"
            [ (Element
"patch", forall a. Pretty a => a -> Doc
Pretty.format Element
patch)
            , (Element
"instrument", forall a. Pretty a => a -> Doc
Pretty.format Instrument
inst)
            , (Element
"trackId", forall a. Pretty a => a -> Doc
Pretty.format Maybe TrackId
trackId)
            , (Element
"element", forall a. Pretty a => a -> Doc
Pretty.format Element
element)
            , (Element
"start", forall a. Pretty a => a -> Doc
Pretty.format RealTime
start)
            , (Element
"duration", forall a. Pretty a => a -> Doc
Pretty.format RealTime
dur)
            , (Element
"controls", forall a. Pretty a => a -> Doc
Pretty.format Map Control Signal
controls)
            , (Element
"attributes", forall a. Pretty a => a -> Doc
Pretty.format Attributes
attrs)
            , (Element
"stack", forall a. Pretty a => a -> Doc
Pretty.format Stack
stack)
            ]

-- | Make a Note for testing.
note :: PatchName -> ScoreT.Instrument -> RealTime -> RealTime -> Note
note :: Element -> Instrument -> RealTime -> RealTime -> Note
note Element
patch Instrument
instrument RealTime
start RealTime
duration = Note
    { patch :: Element
patch = Element
patch
    , instrument :: Instrument
instrument = Instrument
instrument
    , trackId :: Maybe TrackId
trackId = forall a. Maybe a
Nothing
    , element :: Element
element = Element
""
    , start :: RealTime
start = RealTime
start
    , duration :: RealTime
duration = RealTime
duration
    , controls :: Map Control Signal
controls = forall a. Monoid a => a
mempty
    , attributes :: Attributes
attributes = forall a. Monoid a => a
mempty
    , stack :: Stack
stack = Stack
Stack.empty
    }

testNote :: RealTime -> RealTime -> Note
testNote :: RealTime -> RealTime -> Note
testNote = Element -> Instrument -> RealTime -> RealTime -> Note
note Element
"patch" Instrument
"inst"

initialPitch :: Note -> Maybe Pitch.NoteNumber
initialPitch :: Note -> Maybe NoteNumber
initialPitch Note
note = if Maybe NoteNumber
nn forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just NoteNumber
0 then forall a. Maybe a
Nothing else Maybe NoteNumber
nn
    where nn :: Maybe NoteNumber
nn = forall a. Real a => a -> NoteNumber
Pitch.nn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Control -> Note -> Maybe Y
initial Control
Control.pitch Note
note
    -- If the patch said it supports pitch, Control.pitch will always be
    -- present even if that means it's empty.  That will show up as 0 pitch,
    -- so convert that back into Nothing.

controlAt :: RealTime -> Control.Control -> Note -> Maybe Signal.Y
controlAt :: RealTime -> Control -> Note -> Maybe Y
controlAt RealTime
t Control
control = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (kind :: k). Signal kind -> RealTime -> Y
`Signal.at` RealTime
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Map Control Signal
controls

initial :: Control.Control -> Note -> Maybe Signal.Y
initial :: Control -> Note -> Maybe Y
initial Control
control Note
note = RealTime -> Control -> Note -> Maybe Y
controlAt (Note -> RealTime
start Note
note) Control
control Note
note

initial0 :: Control.Control -> Note -> Signal.Y
initial0 :: Control -> Note -> Y
initial0 Control
control =  forall a. a -> Maybe a -> a
fromMaybe Y
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Note -> Maybe Y
initial Control
control

withControl :: Control.Control -> Signal.Signal -> Note -> Note
withControl :: Control -> Signal -> Note -> Note
withControl Control
control Signal
signal Note
note =
    Note
note { controls :: Map Control Signal
controls = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Control
control Signal
signal (Note -> Map Control Signal
controls Note
note) }

withPitch :: Pitch.NoteNumber -> Note -> Note
withPitch :: NoteNumber -> Note -> Note
withPitch = Control -> Signal -> Note -> Note
withControl Control
Control.pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Y -> Signal kind
Signal.constant forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Y
Pitch.nn_to_double

-- * serialize

serialize :: FilePath -> [Note] -> IO Bool
serialize :: String -> [Note] -> IO Bool
serialize = forall a. Serialize a => Int -> Magic a -> String -> a -> IO Bool
Serialize.serialize_rotate Int
4 Magic [Note]
notesMagic
    -- Save more rotations, sometimes I need to debug im errors by replaying
    -- multiple changes.

unserialize :: FilePath -> IO (Either Serialize.UnserializeError [Note])
unserialize :: String -> IO (Either UnserializeError [Note])
unserialize  = forall a.
Serialize a =>
Magic a -> String -> IO (Either UnserializeError a)
Serialize.unserialize Magic [Note]
notesMagic

notesMagic :: Serialize.Magic [Note]
notesMagic :: Magic [Note]
notesMagic = forall {k} (a :: k). Char -> Char -> Char -> Char -> Magic a
Serialize.Magic Char
'n' Char
'o' Char
't' Char
'e'


-- * hash

-- | The Hash is the MD5 digest of the note.
--
-- I used to use CRC32, but got a collision right away:
-- > 2861715819 & 157939100 = 1544801946
-- > 1257719070 & 3909935593 = 1544801946
newtype Hash = Hash ByteString.ByteString
    deriving (Int -> Hash -> ShowS
[Hash] -> ShowS
Hash -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hash] -> ShowS
$cshowList :: [Hash] -> ShowS
show :: Hash -> String
$cshow :: Hash -> String
showsPrec :: Int -> Hash -> ShowS
$cshowsPrec :: Int -> Hash -> ShowS
Show, Hash -> Hash -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c== :: Hash -> Hash -> Bool
Eq, Eq Hash
Hash -> Hash -> Bool
Hash -> Hash -> Ordering
Hash -> Hash -> Hash
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 :: Hash -> Hash -> Hash
$cmin :: Hash -> Hash -> Hash
max :: Hash -> Hash -> Hash
$cmax :: Hash -> Hash -> Hash
>= :: Hash -> Hash -> Bool
$c>= :: Hash -> Hash -> Bool
> :: Hash -> Hash -> Bool
$c> :: Hash -> Hash -> Bool
<= :: Hash -> Hash -> Bool
$c<= :: Hash -> Hash -> Bool
< :: Hash -> Hash -> Bool
$c< :: Hash -> Hash -> Bool
compare :: Hash -> Hash -> Ordering
$ccompare :: Hash -> Hash -> Ordering
Ord, Get Hash
Putter Hash
forall a. Putter a -> Get a -> Serialize a
get :: Get Hash
$cget :: Get Hash
put :: Putter Hash
$cput :: Putter Hash
Serialize.Serialize)

instance Pretty Hash where pretty :: Hash -> Element
pretty = String -> Element
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> String
encodeHash

hash :: Note -> Hash
hash :: Note -> Hash
hash Note
note = ByteString -> Hash
hashBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
Serialize.encode forall a b. (a -> b) -> a -> b
$ Note
note { stack :: Stack
stack = Stack
Stack.empty }

hashBytes :: ByteString.Char8.ByteString -> Hash
hashBytes :: ByteString -> Hash
hashBytes = ByteString -> Hash
Hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
MD5.hash

-- | Encode to a short string which I can stick in a filename.
encodeHash :: Hash -> String
encodeHash :: Hash -> String
encodeHash (Hash ByteString
hash) = ByteString -> String
ByteString.Char8.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fingerprint ByteString
hash

fingerprint :: ByteString.ByteString -> ByteString.ByteString
fingerprint :: ByteString -> ByteString
fingerprint = (Char -> Bool) -> ByteString -> ByteString
ByteString.Char8.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'=') forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.URL.encode

instance Semigroup Hash where
    Hash ByteString
h1 <> :: Hash -> Hash -> Hash
<> Hash ByteString
h2
        | ByteString
h1 forall a. Eq a => a -> a -> Bool
== ByteString
"" = ByteString -> Hash
Hash ByteString
h2
        | ByteString
h2 forall a. Eq a => a -> a -> Bool
== ByteString
"" = ByteString -> Hash
Hash ByteString
h1
        | Bool
otherwise = ByteString -> Hash
Hash forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MD5.hashlazy forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
ByteString.Lazy.fromChunks [ByteString
h1, ByteString
h2]

instance Monoid Hash where
    mempty :: Hash
mempty = ByteString -> Hash
Hash ByteString
""
    mappend :: Hash -> Hash -> Hash
mappend = forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [Hash] -> Hash
mconcat [] = forall a. Monoid a => a
mempty
    -- It's less confusing when mconcat [x] == x.
    mconcat [Hash
x] = Hash
x
    mconcat [Hash]
xs =
        ByteString -> Hash
Hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
MD5.hashlazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
ByteString.Lazy.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Hash -> ByteString
unhash forall a b. (a -> b) -> a -> b
$ [Hash]
xs
        where unhash :: Hash -> ByteString
unhash (Hash ByteString
h) = ByteString
h

fingerprintBytes :: ByteString.ByteString -> String
fingerprintBytes :: ByteString -> String
fingerprintBytes = ByteString -> String
ByteString.Char8.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fingerprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
MD5.hash