-- Copyright 2018 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 module Derive.C.India.Gamakam6 where import qualified Control.Applicative as Applicative import qualified Control.Monad.State as State import qualified Data.Attoparsec.Text as A import qualified Data.Map as Map import qualified Data.Text as Text import qualified Util.Doc as Doc import qualified Util.Lists as Lists import qualified Util.Num as Num import qualified Util.ParseText as ParseText import qualified Util.Segment as Segment import qualified Derive.Args as Args import qualified Derive.Call as Call import qualified Derive.Call.ControlUtil as ControlUtil import qualified Derive.Call.Module as Module import qualified Derive.Derive as Derive import qualified Derive.Library as Library import qualified Derive.PSignal as PSignal import qualified Derive.Parse as Parse import qualified Derive.Pitches as Pitches import qualified Derive.Sig as Sig import qualified Derive.Stream as Stream import qualified Derive.Typecheck as Typecheck import qualified Perform.Pitch as Pitch import qualified Perform.Signal as Signal import qualified Ui.Event as Event import qualified Ui.ScoreTime as ScoreTime import Global import Types module_ :: Module.Module module_ :: Module module_ = Module "india" forall a. Semigroup a => a -> a -> a <> Module "gamakam6" library :: Library.Library library :: Library library = forall a. Monoid a => [a] -> a mconcat [ forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators [ (Symbol Parse.unparsed_call, Generator Control c_pitch_sequence) -- , (Parse.unparsed_call, c_dyn_sequence) ] , forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library Library.transformers [ (Symbol "gamak", Transformer Control c_import_pitch) -- , ("dyn", c_import_dyn) ] , forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library Library.transformers [ (Symbol "sahitya", forall a. Taggable a => Transformer a c_sahitya :: Derive.Transformer Derive.Note) ] ] -- * State type M a = State.StateT PitchState Derive.Deriver a data PitchState = PitchState { -- # maintained automatically -- | Pitch of the underlying note. The Nns below are relative to this. PitchState -> Transposed _current :: !PSignal.Transposed -- | Current pitch value. Starts as the pitch at the end of the previous -- note. , PitchState -> Nn _from :: !Nn -- | Previous swaram. , PitchState -> Nn _prev :: !Nn -- | Next swaram. , PitchState -> Nn _next :: !Nn -- # maintained automatically -- | Transition time between pitch movements. , PitchState -> Normalized _transition :: !Typecheck.Normalized } deriving (Int -> PitchState -> ShowS [PitchState] -> ShowS PitchState -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PitchState] -> ShowS $cshowList :: [PitchState] -> ShowS show :: PitchState -> String $cshow :: PitchState -> String showsPrec :: Int -> PitchState -> ShowS $cshowsPrec :: Int -> PitchState -> ShowS Show) nn_difference :: PSignal.Transposed -> PSignal.Transposed -> Derive.Deriver Nn nn_difference :: Transposed -> Transposed -> Deriver Nn nn_difference Transposed p1 Transposed p2 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a b. (Real a, Fractional b) => a -> b realToFrac forall a b. (a -> b) -> a -> b $ (-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Transposed -> Deriver State Error NoteNumber Pitches.pitch_nn Transposed p1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Transposed -> Deriver State Error NoteNumber Pitches.pitch_nn Transposed p2 get_pitch :: (PitchState -> Nn) -> M PSignal.Transposed get_pitch :: (PitchState -> Nn) -> M Transposed get_pitch PitchState -> Nn get = do Nn nn <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a State.gets PitchState -> Nn get Transposed cur <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a State.gets PitchState -> Transposed _current forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. NoteNumber -> RawPitch a -> RawPitch a Pitches.transpose_nn (forall a. Real a => a -> NoteNumber Pitch.nn Nn nn) Transposed cur -- ** initial state initial_pitch_state :: Typecheck.Normalized -> Derive.PassedArgs Derive.Control -> Derive.Deriver (Maybe PitchState) initial_pitch_state :: Normalized -> PassedArgs Control -> Deriver (Maybe PitchState) initial_pitch_state Normalized transition PassedArgs Control args = do RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs Control args -- If there's no pitch then this is likely at the edge of a slice, and can -- be ignored. TODO I think? forall (m :: * -> *) a b. Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b) justm (RealTime -> Deriver (Maybe Transposed) lookup_pitch RealTime start) forall a b. (a -> b) -> a -> b $ \Transposed current -> do (Maybe Pitch prev, Maybe Pitch next, Maybe Pitch from) <- RealTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch) get_neighbor_pitches RealTime start let prev_step :: Nn prev_step = forall b a. b -> (a -> b) -> Maybe a -> b maybe Nn 0 forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ PassedArgs Control -> Maybe (RealTime, Nn) Args.prev_control PassedArgs Control args let steps_from_current :: Maybe Pitch -> Deriver Nn steps_from_current = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a. a -> Maybe a -> a fromMaybe Nn 0) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse ((Transposed -> Transposed -> Deriver Nn `nn_difference` Transposed current) forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< RealTime -> Pitch -> Deriver Transposed Derive.resolve_pitch RealTime start) Nn prev <- Maybe Pitch -> Deriver Nn steps_from_current Maybe Pitch prev Nn from <- Maybe Pitch -> Deriver Nn steps_from_current forall a b. (a -> b) -> a -> b $ forall a. NoteNumber -> RawPitch a -> RawPitch a Pitches.transpose_nn (forall a. Real a => a -> NoteNumber Pitch.nn Nn prev_step) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Pitch from Nn next <- Maybe Pitch -> Deriver Nn steps_from_current Maybe Pitch next forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ PitchState { _current :: Transposed _current = Transposed current , _from :: Nn _from = Nn from , _prev :: Nn _prev = Nn prev , _next :: Nn _next = Nn next , _transition :: Normalized _transition = Normalized transition } where lookup_pitch :: RealTime -> Deriver (Maybe Transposed) lookup_pitch = RealTime -> Deriver (Maybe Transposed) Call.transposed get_neighbor_pitches :: RealTime -> Derive.Deriver (Maybe PSignal.Pitch, Maybe PSignal.Pitch, Maybe PSignal.Pitch) get_neighbor_pitches :: RealTime -> Deriver (Maybe Pitch, Maybe Pitch, Maybe Pitch) get_neighbor_pitches RealTime start = do Pitch pitch <- Deriver Pitch Derive.get_pitch let prev :: Maybe Pitch prev = Pitch -> RealTime -> Maybe Pitch PSignal.at_negative Pitch pitch RealTime start let next :: Maybe Pitch next = forall a b. (a, b) -> b snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> Pitch -> Maybe (RealTime, Pitch) next_sample RealTime start Pitch pitch forall (m :: * -> *) a. Monad m => a -> m a return (Maybe Pitch prev, Maybe Pitch next, Maybe Pitch prev) next_sample :: RealTime -> PSignal.PSignal -> Maybe (RealTime, PSignal.Pitch) next_sample :: RealTime -> Pitch -> Maybe (RealTime, Pitch) next_sample RealTime x Pitch pitch = do Segment.Segment RealTime _ Pitch _ RealTime x2 Pitch _ <- Pitch -> RealTime -> Maybe (Segment Pitch) PSignal.segment_at Pitch pitch RealTime x (RealTime x2,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Pitch -> RealTime -> Maybe Pitch PSignal.at Pitch pitch RealTime x2 -- * pitch sequence c_import_pitch :: Derive.Transformer Derive.Control c_import_pitch :: Transformer Control c_import_pitch = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module module_ CallName "gamak" forall a. Monoid a => a mempty Doc "Import calls for a gamakam track." forall a b. (a -> b) -> a -> b $ forall y d. Taggable y => Transformer y d -> WithArgDoc (Transformer y d) Sig.call0t forall a b. (a -> b) -> a -> b $ \PassedArgs Control _args -> forall a. Bool -> Module -> Deriver a -> Deriver a Derive.with_imported Bool False (Module module_ forall a. Semigroup a => a -> a -> a <> Module "pitch") c_pitch_sequence :: Derive.Generator Derive.Control c_pitch_sequence :: Generator Control c_pitch_sequence = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 (Module module_ forall a. Semigroup a => a -> a -> a <> Module "pitch") CallName "sequence" forall a. Monoid a => a mempty Doc pitch_sequence_doc forall a b. (a -> b) -> a -> b $ forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "sequence" Doc "Pitch calls." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Normalized transition_env ) forall a b. (a -> b) -> a -> b $ \(Text code, Normalized transition) PassedArgs Control args -> do ScoreTime end <- forall a. PassedArgs a -> Deriver ScoreTime infer_end PassedArgs Control args Maybe PitchState maybe_state <- Normalized -> PassedArgs Control -> Deriver (Maybe PitchState) initial_pitch_state Normalized transition PassedArgs Control args case Maybe PitchState maybe_state of Maybe PitchState Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Monoid a => a mempty Just PitchState state -> do [Control] transpose <- forall a. ScoreTime -> Deriver a -> Deriver a Derive.at (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs Control args) forall a b. (a -> b) -> a -> b $ PitchState -> ScoreTime -> Text -> Deriver [Control] pitch_sequence PitchState state (ScoreTime end forall a. Num a => a -> a -> a - forall a. PassedArgs a -> ScoreTime Args.start PassedArgs Control args) Text code -- Debug.tracepM "transpose" (Args.start args, end, transpose) RealTime real_end <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime end -- End is the next pitch sample. So if the next event -- coincides with or precedes it, it will want to come from -- this pitch, so don't append a 0. Otherwise, the pitch is -- not "attached" to a gamakam, so I add a 0, otherwise it's -- out of tune. -- -- I have to subtract ScoreTime.eta because the pitch sample -- has been warped back from RealTime, so it will lose some -- precision. TODO ugh. let next_gamakam :: Bool next_gamakam = forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool False ((forall a. Ord a => a -> a -> Bool <=ScoreTime end) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Num a => a -> a -> a subtract ScoreTime ScoreTime.eta) (forall a. PassedArgs a -> Maybe ScoreTime next_event PassedArgs Control args) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. Monoid a => [a] -> a mconcat forall a b. (a -> b) -> a -> b $ [Control] transpose forall a. [a] -> [a] -> [a] ++ if Bool next_gamakam then [] else [forall {k} (kind :: k). RealTime -> Nn -> Signal kind Signal.from_sample RealTime real_end Nn 0] where transition_env :: Sig.Parser Typecheck.Normalized transition_env :: Parser Normalized transition_env = forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "transition" EnvironDefault Sig.Both (Nn -> Normalized Typecheck.Normalized Nn 0.5) forall a b. (a -> b) -> a -> b $ Doc "Time for each pitch movement, in proportion of the total time" forall a. Semigroup a => a -> a -> a <> Doc " available." pitch_sequence_doc :: Doc.Doc pitch_sequence_doc :: Doc pitch_sequence_doc = Text -> Doc Doc.Doc forall a b. (a -> b) -> a -> b $ Text "This is a mini-language that describes a transposition curve.\ \ The grammar is a sequence of `Pitch Duration | ']' Pitch | Alias`.\ \ A plain Pitch moves to that pitch, `]` Pitch sets the From running pitch\ \ to the given Pitch, but has zero duration, and Alias is a single letter,\ \ which is itself mapped to a sequence.\ \\nPitch is `[=<>][+\\^v]? | #?[-9-9a-d]? [+\\^v]?`. `=<>` are the running\ \ From pitch, Prev pitch, or Next pitch, and [+\\^v] add or subtract\ \ 1nn, or .5nn, respectively. A number is steps from the current swaram,\ \ and a-d are shorthand for -1 to -4.\ \\nDuration is a sequence of `_` or `.`, where each one doubles or halves\ \ the duration. `:` and `;` stand for short or long absolute duration.\ \\nDefault aliases:\n" forall a. Semigroup a => a -> a -> a <> [Text] -> Text Text.unlines [Char -> Text char Char k forall a. Semigroup a => a -> a -> a <> Text " - " forall a. Semigroup a => a -> a -> a <> Text v | (Char k, Text v) <- forall k a. Map k a -> [(k, a)] Map.toList Map Char Text aliases] where char :: Char -> Text char Char c = Text "`" forall a. Semigroup a => a -> a -> a <> Char -> Text Text.singleton Char c forall a. Semigroup a => a -> a -> a <> Text "`" -- | Start of the next event. 'Args.next' gets the end of the block if there -- is no next event, but I don't want that. next_event :: Derive.PassedArgs a -> Maybe TrackTime next_event :: forall a. PassedArgs a -> Maybe ScoreTime next_event = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Event -> ScoreTime Event.start forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> Maybe a Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. PassedArgs a -> [Event] Args.next_events -- | Infer the end time for the gamakam as the next pitch in the pitch signal, -- which should correspond to the next explicit swaram. infer_end :: Derive.PassedArgs a -> Derive.Deriver TrackTime infer_end :: forall a. PassedArgs a -> Deriver ScoreTime infer_end PassedArgs a args | forall a. PassedArgs a -> ScoreTime Args.end PassedArgs a args forall a. Eq a => a -> a -> Bool /= forall a. PassedArgs a -> ScoreTime Args.start PassedArgs a args = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. PassedArgs a -> ScoreTime Args.end PassedArgs a args | Bool otherwise = do Pitch pitch <- Deriver Pitch Derive.get_pitch RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs a args Maybe ScoreTime next_pitch <- forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (forall a. Time a => a -> Deriver ScoreTime Derive.score forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) (RealTime -> Pitch -> Maybe (RealTime, Pitch) next_sample RealTime start Pitch pitch) let next :: ScoreTime next = forall a. PassedArgs a -> ScoreTime Args.next PassedArgs a args forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall b a. b -> (a -> b) -> Maybe a -> b maybe ScoreTime next (forall a. Ord a => a -> a -> a min ScoreTime next) Maybe ScoreTime next_pitch pitch_sequence :: PitchState -> ScoreTime -> Code -> Derive.Deriver [Signal.Control] pitch_sequence :: PitchState -> ScoreTime -> Text -> Deriver [Control] pitch_sequence PitchState state ScoreTime total_dur Text code = do [Either Alias Call] calls <- forall err a. HasCallStack => (err -> Text) -> Either err a -> Deriver a Derive.require_right ((Text "parsing " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Text code forall a. Semigroup a => a -> a -> a <> Text ": ")<>) forall a b. (a -> b) -> a -> b $ Text -> Either Text [Either Alias Call] parse Text code [Call] calls <- forall err a. HasCallStack => (err -> Text) -> Either err a -> Deriver a Derive.require_right forall a. a -> a id forall a b. (a -> b) -> a -> b $ [Either Alias Call] -> Either Text [Call] resolve_aliases [Either Alias Call] calls [RealTime] starts <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall a. Time a => a -> Deriver RealTime Derive.real forall a b. (a -> b) -> a -> b $ ScoreTime -> [Nn] -> [ScoreTime] slice_time ScoreTime total_dur forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map Call -> Nn call_duration [Call] calls let ranges :: [(RealTime, RealTime)] ranges = forall a b. [a] -> [b] -> [(a, b)] zip [RealTime] starts (forall a. Int -> [a] -> [a] drop Int 1 [RealTime] starts) ([Control] sigs, PitchState _) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s) State.runStateT (forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM ((RealTime, RealTime), Call) -> M Control eval_call (forall a b. [a] -> [b] -> [(a, b)] zip [(RealTime, RealTime)] ranges [Call] calls)) PitchState state forall (m :: * -> *) a. Monad m => a -> m a return [Control] sigs slice_time :: ScoreTime -> [Double] -> [ScoreTime] slice_time :: ScoreTime -> [Nn] -> [ScoreTime] slice_time ScoreTime dur [Nn] slices = forall b a. (b -> a -> b) -> b -> [a] -> [b] scanl forall a. Num a => a -> a -> a (+) ScoreTime 0 forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map ((forall a. Num a => a -> a -> a *ScoreTime one) forall b c a. (b -> c) -> (a -> b) -> a -> c . Nn -> ScoreTime ScoreTime.from_double) [Nn] slices where one :: ScoreTime one = ScoreTime dur forall a. Fractional a => a -> a -> a / Nn -> ScoreTime ScoreTime.from_double (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a Num.sum [Nn] slices) eval_call :: ((RealTime, RealTime), Call) -> M Signal.Control eval_call :: ((RealTime, RealTime), Call) -> M Control eval_call ((RealTime start, RealTime end), Call call) = case Call call of SetFrom Pitch pitch -> do Transposed -> StateT PitchState (Deriver State Error) () set_from forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Pitch -> M Transposed resolve_pitch Pitch pitch forall (m :: * -> *) a. Monad m => a -> m a return forall a. Monoid a => a mempty Move (Movement Pitch to Duration _) -> do Transposed to <- Pitch -> M Transposed resolve_pitch Pitch to Transposed from <- (PitchState -> Nn) -> M Transposed get_pitch PitchState -> Nn _from Transposed -> StateT PitchState (Deriver State Error) () set_from Transposed to RealTime -> Transposed -> RealTime -> Transposed -> M Control move_pitch RealTime start Transposed from RealTime end Transposed to set_from :: PSignal.Transposed -> M () set_from :: Transposed -> StateT PitchState (Deriver State Error) () set_from Transposed pitch = do Transposed cur <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a State.gets PitchState -> Transposed _current Nn nn <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ Transposed -> Transposed -> Deriver Nn nn_difference Transposed pitch Transposed cur forall s (m :: * -> *). MonadState s m => (s -> s) -> m () State.modify' forall a b. (a -> b) -> a -> b $ \PitchState state -> PitchState state { _from :: Nn _from = Nn nn } resolve_pitch :: Pitch -> M PSignal.Transposed resolve_pitch :: Pitch -> M Transposed resolve_pitch (Pitch From from Int steps Nn nn) = do Transposed base <- case From from of From Current -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a State.gets PitchState -> Transposed _current From From -> (PitchState -> Nn) -> M Transposed get_pitch PitchState -> Nn _from From Prev -> (PitchState -> Nn) -> M Transposed get_pitch PitchState -> Nn _prev From Next -> (PitchState -> Nn) -> M Transposed get_pitch PitchState -> Nn _next forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall {t} {a}. (Eq t, Num t) => (t -> a -> a) -> t -> a -> a apply (forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose forall b c a. (b -> c) -> (a -> b) -> a -> c . Nn -> Transpose Pitch.Diatonic forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (Integral a, Num b) => a -> b fromIntegral) Int steps forall a b. (a -> b) -> a -> b $ forall {t} {a}. (Eq t, Num t) => (t -> a -> a) -> t -> a -> a apply forall a. NoteNumber -> RawPitch a -> RawPitch a Pitches.transpose_nn (forall a. Real a => a -> NoteNumber Pitch.nn Nn nn) forall a b. (a -> b) -> a -> b $ Transposed base where apply :: (t -> a -> a) -> t -> a -> a apply t -> a -> a f t n | t n forall a. Eq a => a -> a -> Bool == t 0 = forall a. a -> a id | Bool otherwise = t -> a -> a f t n move_pitch :: RealTime -> PSignal.Transposed -> RealTime -> PSignal.Transposed -> M Signal.Control move_pitch :: RealTime -> Transposed -> RealTime -> Transposed -> M Control move_pitch RealTime start Transposed from RealTime end Transposed to = do Typecheck.Normalized Nn transition <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a State.gets PitchState -> Normalized _transition let curve :: Curve curve = (Nn -> Nn) -> Curve ControlUtil.Function forall a b. (a -> b) -> a -> b $ Nn -> Nn -> Nn -> Nn ControlUtil.sigmoid (Nn 1forall a. Num a => a -> a -> a -Nn transition) (Nn 1forall a. Num a => a -> a -> a -Nn transition) Transposed cur <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a State.gets PitchState -> Transposed _current Nn from <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ Transposed -> Transposed -> Deriver Nn nn_difference Transposed from Transposed cur Nn to <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ Transposed -> Transposed -> Deriver Nn nn_difference Transposed to Transposed cur forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ Curve -> RealTime -> Nn -> RealTime -> Nn -> Deriver Control ControlUtil.make_segment Curve curve RealTime start Nn from RealTime end Nn to -- * aliases type Error = Text resolve_aliases :: [Either Alias Call] -> Either Error [Call] resolve_aliases :: [Either Alias Call] -> Either Text [Call] resolve_aliases = forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM (forall {t}. (Ord t, Num t) => t -> Either Alias Call -> Either Text [Call] resolve Integer 0) where resolve :: t -> Either Alias Call -> Either Text [Call] resolve t _ (Right Call call) = forall (m :: * -> *) a. Monad m => a -> m a return [Call call] resolve t depth (Left (Alias Char alias)) | t depth forall a. Ord a => a -> a -> Bool >= t 5 = forall a b. a -> Either a b Left Text "too many levels of aliases" | Bool otherwise = do Text expr <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a tryJust (Text "unknown alias: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Char alias) forall a b. (a -> b) -> a -> b $ forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Char alias Map Char Text aliases [Either Alias Call] calls <- forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first ((Text "in alias " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Char alias forall a. Semigroup a => a -> a -> a <> Text ": ")<>) forall a b. (a -> b) -> a -> b $ Text -> Either Text [Either Alias Call] parse Text expr forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM (t -> Either Alias Call -> Either Text [Call] resolve (t depthforall a. Num a => a -> a -> a +t 1)) [Either Alias Call] calls aliases :: Map Char Text aliases :: Map Char Text aliases = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [ (Char 'C', Text "]0") , (Char 'N', Text "#0+.#0\\") , (Char 'U', Text "#0\\.#0+.") , (Char 'n', Text "#0^.#0v.") , (Char 'u', Text "#0v.#0^.") ] -- * call types type Parser a = A.Parser a data Call = SetFrom !Pitch | Move !Movement deriving (Call -> Call -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Call -> Call -> Bool $c/= :: Call -> Call -> Bool == :: Call -> Call -> Bool $c== :: Call -> Call -> Bool Eq, Int -> Call -> ShowS [Call] -> ShowS Call -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Call] -> ShowS $cshowList :: [Call] -> ShowS show :: Call -> String $cshow :: Call -> String showsPrec :: Int -> Call -> ShowS $cshowsPrec :: Int -> Call -> ShowS Show) data Alias = Alias !Char deriving (Alias -> Alias -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Alias -> Alias -> Bool $c/= :: Alias -> Alias -> Bool == :: Alias -> Alias -> Bool $c== :: Alias -> Alias -> Bool Eq, Int -> Alias -> ShowS [Alias] -> ShowS Alias -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Alias] -> ShowS $cshowList :: [Alias] -> ShowS show :: Alias -> String $cshow :: Alias -> String showsPrec :: Int -> Alias -> ShowS $cshowsPrec :: Int -> Alias -> ShowS Show) data Movement = Movement !Pitch !Duration deriving (Movement -> Movement -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Movement -> Movement -> Bool $c/= :: Movement -> Movement -> Bool == :: Movement -> Movement -> Bool $c== :: Movement -> Movement -> Bool Eq, Int -> Movement -> ShowS [Movement] -> ShowS Movement -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Movement] -> ShowS $cshowList :: [Movement] -> ShowS show :: Movement -> String $cshow :: Movement -> String showsPrec :: Int -> Movement -> ShowS $cshowsPrec :: Int -> Movement -> ShowS Show) data Pitch = Pitch !From !Steps !Nn deriving (Pitch -> Pitch -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Pitch -> Pitch -> Bool $c/= :: Pitch -> Pitch -> Bool == :: Pitch -> Pitch -> Bool $c== :: Pitch -> Pitch -> Bool Eq, Int -> Pitch -> ShowS [Pitch] -> ShowS Pitch -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Pitch] -> ShowS $cshowList :: [Pitch] -> ShowS show :: Pitch -> String $cshow :: Pitch -> String showsPrec :: Int -> Pitch -> ShowS $cshowsPrec :: Int -> Pitch -> ShowS Show) data From = From | Prev | Current | Next deriving (From -> From -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: From -> From -> Bool $c/= :: From -> From -> Bool == :: From -> From -> Bool $c== :: From -> From -> Bool Eq, Int -> From -> ShowS [From] -> ShowS From -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [From] -> ShowS $cshowList :: [From] -> ShowS show :: From -> String $cshow :: From -> String showsPrec :: Int -> From -> ShowS $cshowsPrec :: Int -> From -> ShowS Show) -- | Relative scale degrees. type Steps = Int -- | Relative NoteNumbers. type Nn = Double -- | How much time the movement takes. data Duration = Relative !Double | AbsoluteShort | AbsoluteLong deriving (Duration -> Duration -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Duration -> Duration -> Bool $c/= :: Duration -> Duration -> Bool == :: Duration -> Duration -> Bool $c== :: Duration -> Duration -> Bool Eq, Int -> Duration -> ShowS [Duration] -> ShowS Duration -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Duration] -> ShowS $cshowList :: [Duration] -> ShowS show :: Duration -> String $cshow :: Duration -> String showsPrec :: Int -> Duration -> ShowS $cshowsPrec :: Int -> Duration -> ShowS Show) -- | Text representing unparsed Calls. type Code = Text call_duration :: Call -> Double call_duration :: Call -> Nn call_duration (SetFrom Pitch _) = Nn 0 call_duration (Move (Movement Pitch _ Duration dur)) = case Duration dur of Relative Nn dur -> Nn dur -- TODO not implemented Duration AbsoluteLong -> Nn 1 Duration AbsoluteShort -> Nn 1 -- * parse parse :: Code -> Either Text [Either Alias Call] parse :: Text -> Either Text [Either Alias Call] parse = forall a. Parser a -> Text -> Either Text a ParseText.parse1 Parser [Either Alias Call] p_calls p_calls :: Parser [Either Alias Call] p_calls :: Parser [Either Alias Call] p_calls = forall (f :: * -> *) a. Alternative f => f a -> f [a] Applicative.many forall a b. (a -> b) -> a -> b $ forall a b. a -> Either a b Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser Alias p_alias forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall a b. b -> Either a b Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Parser Text Call p_set_from forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Movement -> Call Move forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser Movement p_movement) p_set_from :: Parser Call p_set_from :: Parser Text Call p_set_from = Pitch -> Call SetFrom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Char -> Parser Char A.char Char ']' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> Parser Text Pitch p_pitch) p_alias :: Parser Alias p_alias :: Parser Alias p_alias = Char -> Alias Alias forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Char -> Bool) -> Parser Char A.satisfy Char -> Bool is_alias where is_alias :: Char -> Bool is_alias Char c = Char last_letter_negative forall a. Ord a => a -> a -> Bool < Char c Bool -> Bool -> Bool && Char c forall a. Ord a => a -> a -> Bool <= Char 'z' Bool -> Bool -> Bool || Char 'A' forall a. Ord a => a -> a -> Bool <= Char c Bool -> Bool -> Bool && Char c forall a. Ord a => a -> a -> Bool <= Char 'Z' p_movement :: Parser Movement p_movement :: Parser Movement p_movement = Pitch -> Duration -> Movement Movement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser Text Pitch p_pitch forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Duration p_duration p_duration :: Parser Duration p_duration :: Parser Duration p_duration = Parser Duration p_longer forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Parser Duration p_shorter forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall a. [(Char, a)] -> Parser a choose_char [(Char ':', Duration AbsoluteShort), (Char ';', Duration AbsoluteLong)] forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall (f :: * -> *) a. Applicative f => a -> f a pure (Nn -> Duration Relative Nn 1) where p_longer :: Parser Duration p_longer = do Text n <- (Char -> Bool) -> Parser Text A.takeWhile1 (forall a. Eq a => a -> a -> Bool ==Char '_') forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Nn -> Duration Relative forall a b. (a -> b) -> a -> b $ forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Text -> Int Text.length Text n forall a. Num a => a -> a -> a + Int 1 p_shorter :: Parser Duration p_shorter = do Text n <- (Char -> Bool) -> Parser Text A.takeWhile1 (forall a. Eq a => a -> a -> Bool ==Char '.') forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Nn -> Duration Relative forall a b. (a -> b) -> a -> b $ Nn 1 forall a. Fractional a => a -> a -> a / Nn 2forall a b. (Num a, Integral b) => a -> b -> a ^(forall a b. (Integral a, Num b) => a -> b fromIntegral (Text -> Int Text.length Text n)) -- | [=<>] [+\^v]? | #?[0-9a-d]? [+\^v]? p_pitch :: Parser Pitch p_pitch :: Parser Text Pitch p_pitch = do (Text matched, Pitch pitch) <- forall a. Parser a -> Parser (Text, a) A.match forall a b. (a -> b) -> a -> b $ Parser Text Pitch p_pitch_from forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> (From -> Int -> Nn -> Pitch Pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser From p_from forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (Parser Text Int p_steps forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall (f :: * -> *) a. Applicative f => a -> f a pure Int 0) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Nn p_nn) forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Text -> Bool Text.null Text matched) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. MonadFail m => String -> m a fail String "empty pitch" forall (m :: * -> *) a. Monad m => a -> m a return Pitch pitch p_pitch_from :: Parser Pitch p_pitch_from :: Parser Text Pitch p_pitch_from = From -> Int -> Nn -> Pitch Pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser From from forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (f :: * -> *) a. Applicative f => a -> f a pure Int 0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Nn p_nn where from :: Parser From from = forall a. [(Char, a)] -> Parser a choose_char [ (Char '=', From From) , (Char '<', From Prev) , (Char '>', From Next) ] p_steps :: Parser Steps p_steps :: Parser Text Int p_steps = Parser Text Int p_number forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Parser Text Int p_letter_negative p_nn :: Parser Nn p_nn :: Parser Nn p_nn = forall a. [(Char, a)] -> Parser a choose_char [ (Char '+', Nn 1) , (Char '\\', -Nn 1) , (Char '^', Nn 0.5) , (Char 'v', -Nn 0.5) ] forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall (f :: * -> *) a. Applicative f => a -> f a pure Nn 0 -- TODO alternately, ^v and ',. But , looks a lot like . -- or maybe {} and []? No, ] is taken. -- +? and ^v? -- p_nn = choose_char -- [ ('^', 1) -- , ('v', -1) -- , ('\'', 0.5) -- , (',', -0.5) -- ] <|> pure 0 p_from :: Parser From p_from :: Parser From p_from = forall (f :: * -> *) a. Alternative f => a -> f a -> f a A.option From Current (Char -> Parser Char A.char Char '#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> forall (f :: * -> *) a. Applicative f => a -> f a pure From From) p_number :: Parser Int p_number :: Parser Text Int p_number = do Int sign <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a A.option Int 1 (Char -> Parser Char A.char Char '-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall (m :: * -> *) a. Monad m => a -> m a return (-Int 1)) Char digit <- (Char -> Bool) -> Parser Char A.satisfy forall a b. (a -> b) -> a -> b $ \Char c -> Char '0' forall a. Ord a => a -> a -> Bool <= Char c Bool -> Bool -> Bool && Char c forall a. Ord a => a -> a -> Bool <= Char '9' forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Int sign forall a. Num a => a -> a -> a * (forall a. Enum a => a -> Int fromEnum Char digit forall a. Num a => a -> a -> a - forall a. Enum a => a -> Int fromEnum Char '0') p_letter_negative :: Parser Int p_letter_negative :: Parser Text Int p_letter_negative = do Char digit <- (Char -> Bool) -> Parser Char A.satisfy forall a b. (a -> b) -> a -> b $ \Char c -> Char 'a' forall a. Ord a => a -> a -> Bool <= Char c Bool -> Bool -> Bool && Char c forall a. Ord a => a -> a -> Bool <= Char last_letter_negative forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. Enum a => a -> Int fromEnum Char 'a' forall a. Num a => a -> a -> a - forall a. Enum a => a -> Int fromEnum Char digit forall a. Num a => a -> a -> a - Int 1 last_letter_negative :: Char last_letter_negative :: Char last_letter_negative = Char 'd' choose_char :: [(Char, a)] -> Parser a choose_char :: forall a. [(Char, a)] -> Parser a choose_char = forall (f :: * -> *) a. Alternative f => [f a] -> f a A.choice forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (\(Char c, a a) -> Char -> Parser Char A.char Char c forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> forall (f :: * -> *) a. Applicative f => a -> f a pure a a) -- * misc c_sahitya :: Derive.Taggable a => Derive.Transformer a c_sahitya :: forall a. Taggable a => Transformer a c_sahitya = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module module_ CallName "sahitya" forall a. Monoid a => a mempty (Doc "Ignore the transformed deriver. Put this on a track to ignore its" forall a. Semigroup a => a -> a -> a <> Doc " contents, and put in sahitya.") forall a b. (a -> b) -> a -> b $ forall y d. Taggable y => Transformer y d -> WithArgDoc (Transformer y d) Sig.call0t forall a b. (a -> b) -> a -> b $ \PassedArgs a _args Deriver (Stream a) _deriver -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Stream a Stream.empty