-- 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
(Note -> Note -> Bool) -> (Note -> Note -> Bool) -> Eq Note
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
(Int -> Note -> ShowS)
-> (Note -> String) -> ([Note] -> ShowS) -> Show Note
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 RealTime -> RealTime -> RealTime
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) =
        Putter Element
forall a. Serialize a => Putter a
put Element
a PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter Instrument
forall a. Serialize a => Putter a
put Instrument
b PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter (Maybe TrackId)
forall a. Serialize a => Putter a
put Maybe TrackId
c PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter Element
forall a. Serialize a => Putter a
put Element
d PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter RealTime
forall a. Serialize a => Putter a
put RealTime
e PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter RealTime
forall a. Serialize a => Putter a
put RealTime
f PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter (Map Control Signal)
forall a. Serialize a => Putter a
put Map Control Signal
g PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter Attributes
forall a. Serialize a => Putter a
put Attributes
h
        PutM () -> PutM () -> PutM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter Stack
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 (Element
 -> Instrument
 -> Maybe TrackId
 -> Element
 -> RealTime
 -> RealTime
 -> Map Control Signal
 -> Attributes
 -> Stack
 -> Note)
-> Get Element
-> Get
     (Instrument
      -> Maybe TrackId
      -> Element
      -> RealTime
      -> RealTime
      -> Map Control Signal
      -> Attributes
      -> Stack
      -> Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Element
forall a. Serialize a => Get a
get Get
  (Instrument
   -> Maybe TrackId
   -> Element
   -> RealTime
   -> RealTime
   -> Map Control Signal
   -> Attributes
   -> Stack
   -> Note)
-> Get Instrument
-> Get
     (Maybe TrackId
      -> Element
      -> RealTime
      -> RealTime
      -> Map Control Signal
      -> Attributes
      -> Stack
      -> Note)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Instrument
forall a. Serialize a => Get a
get Get
  (Maybe TrackId
   -> Element
   -> RealTime
   -> RealTime
   -> Map Control Signal
   -> Attributes
   -> Stack
   -> Note)
-> Get (Maybe TrackId)
-> Get
     (Element
      -> RealTime
      -> RealTime
      -> Map Control Signal
      -> Attributes
      -> Stack
      -> Note)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Maybe TrackId)
forall a. Serialize a => Get a
get Get
  (Element
   -> RealTime
   -> RealTime
   -> Map Control Signal
   -> Attributes
   -> Stack
   -> Note)
-> Get Element
-> Get
     (RealTime
      -> RealTime -> Map Control Signal -> Attributes -> Stack -> Note)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Element
forall a. Serialize a => Get a
get Get
  (RealTime
   -> RealTime -> Map Control Signal -> Attributes -> Stack -> Note)
-> Get RealTime
-> Get
     (RealTime -> Map Control Signal -> Attributes -> Stack -> Note)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get RealTime
forall a. Serialize a => Get a
get Get (RealTime -> Map Control Signal -> Attributes -> Stack -> Note)
-> Get RealTime
-> Get (Map Control Signal -> Attributes -> Stack -> Note)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get RealTime
forall a. Serialize a => Get a
get Get (Map Control Signal -> Attributes -> Stack -> Note)
-> Get (Map Control Signal) -> Get (Attributes -> Stack -> Note)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Map Control Signal)
forall a. Serialize a => Get a
get Get (Attributes -> Stack -> Note)
-> Get Attributes -> Get (Stack -> Note)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Attributes
forall a. Serialize a => Get a
get
        Get (Stack -> Note) -> Get Stack -> Get Note
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Stack
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", Element -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Element
patch)
            , (Element
"instrument", Instrument -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Instrument
inst)
            , (Element
"trackId", Maybe TrackId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe TrackId
trackId)
            , (Element
"element", Element -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Element
element)
            , (Element
"start", RealTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RealTime
start)
            , (Element
"duration", RealTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RealTime
dur)
            , (Element
"controls", Map Control Signal -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map Control Signal
controls)
            , (Element
"attributes", Attributes -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Attributes
attrs)
            , (Element
"stack", Stack -> Doc
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 = Maybe 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 = Map Control Signal
forall a. Monoid a => a
mempty
    , attributes :: 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 Maybe NoteNumber -> Maybe NoteNumber -> Bool
forall a. Eq a => a -> a -> Bool
== NoteNumber -> Maybe NoteNumber
forall a. a -> Maybe a
Just NoteNumber
0 then Maybe NoteNumber
forall a. Maybe a
Nothing else Maybe NoteNumber
nn
    where nn :: Maybe NoteNumber
nn = Y -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (Y -> NoteNumber) -> Maybe Y -> Maybe NoteNumber
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 = (Signal -> Y) -> Maybe Signal -> Maybe Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Signal -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
t) (Maybe Signal -> Maybe Y)
-> (Note -> Maybe Signal) -> Note -> Maybe Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Map Control Signal -> Maybe Signal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control (Map Control Signal -> Maybe Signal)
-> (Note -> Map Control Signal) -> Note -> Maybe Signal
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 =  Y -> Maybe Y -> Y
forall a. a -> Maybe a -> a
fromMaybe Y
0 (Maybe Y -> Y) -> (Note -> Maybe Y) -> Note -> Y
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 = Control -> Signal -> Map Control Signal -> Map Control Signal
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 (Signal -> Note -> Note)
-> (NoteNumber -> Signal) -> NoteNumber -> Note -> Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Signal
forall {k} (kind :: k). Y -> Signal kind
Signal.constant (Y -> Signal) -> (NoteNumber -> Y) -> NoteNumber -> Signal
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 = Int -> Magic [Note] -> String -> [Note] -> IO Bool
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  = Magic [Note] -> String -> IO (Either UnserializeError [Note])
forall a.
Serialize a =>
Magic a -> String -> IO (Either UnserializeError a)
Serialize.unserialize Magic [Note]
notesMagic

notesMagic :: Serialize.Magic [Note]
notesMagic :: Magic [Note]
notesMagic = Char -> Char -> Char -> Char -> Magic [Note]
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
(Int -> Hash -> ShowS)
-> (Hash -> String) -> ([Hash] -> ShowS) -> Show Hash
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
(Hash -> Hash -> Bool) -> (Hash -> Hash -> Bool) -> Eq Hash
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
Eq Hash
-> (Hash -> Hash -> Ordering)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Hash)
-> (Hash -> Hash -> Hash)
-> Ord 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
Putter Hash -> Get Hash -> Serialize 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 (String -> Element) -> (Hash -> String) -> Hash -> Element
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 (ByteString -> Hash) -> (Note -> ByteString) -> Note -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode (Note -> Hash) -> Note -> Hash
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 (ByteString -> Hash)
-> (ByteString -> ByteString) -> ByteString -> 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 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fingerprint ByteString
hash

fingerprint :: ByteString.ByteString -> ByteString.ByteString
fingerprint :: ByteString -> ByteString
fingerprint = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
ByteString.Char8.spanEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=') (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" = ByteString -> Hash
Hash ByteString
h2
        | ByteString
h2 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" = ByteString -> Hash
Hash ByteString
h1
        | Bool
otherwise = ByteString -> Hash
Hash (ByteString -> Hash) -> ByteString -> Hash
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MD5.hashlazy (ByteString -> ByteString) -> ByteString -> ByteString
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 = Hash -> Hash -> Hash
forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [Hash] -> Hash
mconcat [] = Hash
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 (ByteString -> Hash) -> ([Hash] -> ByteString) -> [Hash] -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
MD5.hashlazy (ByteString -> ByteString)
-> ([Hash] -> ByteString) -> [Hash] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
ByteString.Lazy.fromChunks ([ByteString] -> ByteString)
-> ([Hash] -> [ByteString]) -> [Hash] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Hash -> ByteString) -> [Hash] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Hash -> ByteString
unhash ([Hash] -> Hash) -> [Hash] -> Hash
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 (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fingerprint (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
MD5.hash