{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-
    Pattern.hs - core representation of Tidal patterns
    Copyright (C) 2020 Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

module Sound.Tidal.Pattern (module Sound.Tidal.Pattern,
                            module Sound.Tidal.Time
                           )
where

import           Prelude hiding ((<*), (*>))

import           Control.Applicative (liftA2)
import           GHC.Generics
import           Control.DeepSeq (NFData)
import           Control.Monad ((>=>))
import qualified Data.Map.Strict as Map
import           Data.Maybe (isJust, fromJust, catMaybes, mapMaybe)
import           Data.List (delete, findIndex, sort)
import           Data.Word (Word8)
import           Data.Data (Data) -- toConstr
import           Data.Typeable (Typeable)
import           Data.Fixed (mod')

import           Sound.Tidal.Time

------------------------------------------------------------------------
-- * Types

-- | an Arc and some named control values
data State = State {State -> Arc
arc :: Arc,
                    State -> ValueMap
controls :: ValueMap
                   }

-- | A datatype representing events taking place over time
data Pattern a = Pattern {forall a. Pattern a -> State -> [Event a]
query :: State -> [Event a]}
  deriving ((forall x. Pattern a -> Rep (Pattern a) x)
-> (forall x. Rep (Pattern a) x -> Pattern a)
-> Generic (Pattern a)
forall x. Rep (Pattern a) x -> Pattern a
forall x. Pattern a -> Rep (Pattern a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Pattern a) x -> Pattern a
forall a x. Pattern a -> Rep (Pattern a) x
$cto :: forall a x. Rep (Pattern a) x -> Pattern a
$cfrom :: forall a x. Pattern a -> Rep (Pattern a) x
Generic, (forall a b. (a -> b) -> Pattern a -> Pattern b)
-> (forall a b. a -> Pattern b -> Pattern a) -> Functor Pattern
forall a b. a -> Pattern b -> Pattern a
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Pattern b -> Pattern a
$c<$ :: forall a b. a -> Pattern b -> Pattern a
fmap :: forall a b. (a -> b) -> Pattern a -> Pattern b
$cfmap :: forall a b. (a -> b) -> Pattern a -> Pattern b
Functor)

instance NFData a => NFData (Pattern a)

-- type StateMap = Map.Map String (Pattern Value)
type ControlPattern = Pattern ValueMap

-- * Applicative and friends

instance Applicative Pattern where
  -- | Repeat the given value once per cycle, forever
  pure :: forall a. a -> Pattern a
pure a
v = (State -> [Event a]) -> Pattern a
forall a. (State -> [Event a]) -> Pattern a
Pattern ((State -> [Event a]) -> Pattern a)
-> (State -> [Event a]) -> Pattern a
forall a b. (a -> b) -> a -> b
$ \(State Arc
a ValueMap
_) ->
    (Arc -> Event a) -> [Arc] -> [Event a]
forall a b. (a -> b) -> [a] -> [b]
map (\Arc
a' -> Context -> Maybe Arc -> Arc -> a -> Event a
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([((Int, Int), (Int, Int))] -> Context
Context []) (Arc -> Maybe Arc
forall a. a -> Maybe a
Just Arc
a') (Arc -> Arc -> Arc
sect Arc
a Arc
a') a
v) ([Arc] -> [Event a]) -> [Arc] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Arc -> [Arc]
cycleArcsInArc Arc
a

  <*> :: forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
(<*>) = Pattern (a -> b) -> Pattern a -> Pattern b
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatBoth

-- | Like <*>, but the 'wholes' come from the left
(<*) :: Pattern (a -> b) -> Pattern a -> Pattern b
<* :: forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
(<*) = Pattern (a -> b) -> Pattern a -> Pattern b
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatLeft

-- | Like <*>, but the 'wholes' come from the right
(*>) :: Pattern (a -> b) -> Pattern a -> Pattern b
*> :: forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
(*>) = Pattern (a -> b) -> Pattern a -> Pattern b
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatRight

infixl 4 <*, *>
applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPat :: forall a b.
(Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc))
-> Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPat Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)
combineWholes Pattern (a -> b)
pf Pattern a
px = (State -> [Event b]) -> Pattern b
forall a. (State -> [Event a]) -> Pattern a
Pattern State -> [Event b]
q
    where q :: State -> [Event b]
q State
st = [Maybe (Event b)] -> [Event b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Event b)] -> [Event b]) -> [Maybe (Event b)] -> [Event b]
forall a b. (a -> b) -> a -> b
$ (EventF Arc (a -> b) -> [Maybe (Event b)])
-> [EventF Arc (a -> b)] -> [Maybe (Event b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc (a -> b) -> [Maybe (Event b)]
forall {b}. EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match ([EventF Arc (a -> b)] -> [Maybe (Event b)])
-> [EventF Arc (a -> b)] -> [Maybe (Event b)]
forall a b. (a -> b) -> a -> b
$ Pattern (a -> b) -> State -> [EventF Arc (a -> b)]
forall a. Pattern a -> State -> [Event a]
query Pattern (a -> b)
pf State
st
            where
              match :: EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match ef :: EventF Arc (a -> b)
ef@(Event (Context [((Int, Int), (Int, Int))]
c) Maybe Arc
_ Arc
fPart a -> b
f) =
                (EventF Arc a -> Maybe (EventF Arc b))
-> [EventF Arc a] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> [a] -> [b]
map
                (\ex :: EventF Arc a
ex@(Event (Context [((Int, Int), (Int, Int))]
c') Maybe Arc
_ Arc
xPart a
x) ->
                  do Maybe Arc
whole' <- Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)
combineWholes (EventF Arc (a -> b) -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc (a -> b)
ef) (EventF Arc a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc a
ex)
                     Arc
part' <- Arc -> Arc -> Maybe Arc
subArc Arc
fPart Arc
xPart
                     EventF Arc b -> Maybe (EventF Arc b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([((Int, Int), (Int, Int))] -> Context
Context ([((Int, Int), (Int, Int))] -> Context)
-> [((Int, Int), (Int, Int))] -> Context
forall a b. (a -> b) -> a -> b
$ [((Int, Int), (Int, Int))]
c [((Int, Int), (Int, Int))]
-> [((Int, Int), (Int, Int))] -> [((Int, Int), (Int, Int))]
forall a. [a] -> [a] -> [a]
++ [((Int, Int), (Int, Int))]
c') Maybe Arc
whole' Arc
part' (a -> b
f a
x))
                )
                (Pattern a -> State -> [EventF Arc a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
px (State -> [EventF Arc a]) -> State -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ State
st {arc :: Arc
arc = EventF Arc (a -> b) -> Arc
forall a. Event a -> Arc
wholeOrPart EventF Arc (a -> b)
ef})

applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatBoth :: forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatBoth Pattern (a -> b)
pf Pattern a
px = (State -> [Event b]) -> Pattern b
forall a. (State -> [Event a]) -> Pattern a
Pattern State -> [Event b]
q
    where q :: State -> [Event b]
q State
st = [Maybe (Event b)] -> [Event b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Event b)] -> [Event b]) -> [Maybe (Event b)] -> [Event b]
forall a b. (a -> b) -> a -> b
$ ((EventF Arc (a -> b) -> [Maybe (Event b)])
-> [EventF Arc (a -> b)] -> [Maybe (Event b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc (a -> b) -> [Maybe (Event b)]
forall {b}. EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match ([EventF Arc (a -> b)] -> [Maybe (Event b)])
-> [EventF Arc (a -> b)] -> [Maybe (Event b)]
forall a b. (a -> b) -> a -> b
$ Pattern (a -> b) -> State -> [EventF Arc (a -> b)]
forall a. Pattern a -> State -> [Event a]
query Pattern (a -> b)
pf State
st) [Maybe (Event b)] -> [Maybe (Event b)] -> [Maybe (Event b)]
forall a. [a] -> [a] -> [a]
++ ((EventF Arc a -> [Maybe (Event b)])
-> [EventF Arc a] -> [Maybe (Event b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc a -> [Maybe (Event b)]
matchX ([EventF Arc a] -> [Maybe (Event b)])
-> [EventF Arc a] -> [Maybe (Event b)]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [EventF Arc a]
forall a. Pattern a -> State -> [Event a]
query (Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
filterAnalog Pattern a
px) State
st)
            where
              -- match analog events from pf with all events from px
              match :: EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match ef :: EventF Arc (a -> b)
ef@(Event Context
_ Maybe Arc
Nothing Arc
fPart a -> b
_)   = (EventF Arc a -> Maybe (EventF Arc b))
-> [EventF Arc a] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> [a] -> [b]
map (EventF Arc (a -> b) -> EventF Arc a -> Maybe (EventF Arc b)
forall {t} {b}.
EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
withFX EventF Arc (a -> b)
ef) (Pattern a -> State -> [EventF Arc a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
px (State -> [EventF Arc a]) -> State -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ State
st {arc :: Arc
arc = Arc
fPart}) -- analog
              -- match digital events from pf with digital events from px
              match ef :: EventF Arc (a -> b)
ef@(Event Context
_ (Just Arc
fWhole) Arc
_ a -> b
_) = (EventF Arc a -> Maybe (EventF Arc b))
-> [EventF Arc a] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> [a] -> [b]
map (EventF Arc (a -> b) -> EventF Arc a -> Maybe (EventF Arc b)
forall {t} {b}.
EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
withFX EventF Arc (a -> b)
ef) (Pattern a -> State -> [EventF Arc a]
forall a. Pattern a -> State -> [Event a]
query (Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
filterDigital Pattern a
px) (State -> [EventF Arc a]) -> State -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ State
st {arc :: Arc
arc = Arc
fWhole}) -- digital
              -- match analog events from px (constrained above) with digital events from px
              matchX :: EventF Arc a -> [Maybe (Event b)]
matchX ex :: EventF Arc a
ex@(Event Context
_ Maybe Arc
Nothing Arc
fPart a
_)  = (EventF Arc (a -> b) -> Maybe (Event b))
-> [EventF Arc (a -> b)] -> [Maybe (Event b)]
forall a b. (a -> b) -> [a] -> [b]
map (EventF Arc (a -> b) -> EventF Arc a -> Maybe (Event b)
forall {t} {b}.
EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
`withFX` EventF Arc a
ex) (Pattern (a -> b) -> State -> [EventF Arc (a -> b)]
forall a. Pattern a -> State -> [Event a]
query (Pattern (a -> b) -> Pattern (a -> b)
forall a. Pattern a -> Pattern a
filterDigital Pattern (a -> b)
pf) (State -> [EventF Arc (a -> b)]) -> State -> [EventF Arc (a -> b)]
forall a b. (a -> b) -> a -> b
$ State
st {arc :: Arc
arc = Arc
fPart}) -- digital
              matchX EventF Arc a
_ = String -> [Maybe (Event b)]
forall a. HasCallStack => String -> a
error String
"can't happen"
              withFX :: EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
withFX EventF Arc (t -> b)
ef EventF Arc t
ex = do Maybe Arc
whole' <- Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)
subMaybeArc (EventF Arc (t -> b) -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc (t -> b)
ef) (EventF Arc t -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc t
ex)
                                Arc
part' <- Arc -> Arc -> Maybe Arc
subArc (EventF Arc (t -> b) -> Arc
forall a b. EventF a b -> a
part EventF Arc (t -> b)
ef) (EventF Arc t -> Arc
forall a b. EventF a b -> a
part EventF Arc t
ex)
                                EventF Arc b -> Maybe (EventF Arc b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts [EventF Arc (t -> b) -> Context
forall a b. EventF a b -> Context
context EventF Arc (t -> b)
ef, EventF Arc t -> Context
forall a b. EventF a b -> Context
context EventF Arc t
ex]) Maybe Arc
whole' Arc
part' (EventF Arc (t -> b) -> t -> b
forall a b. EventF a b -> b
value EventF Arc (t -> b)
ef (t -> b) -> t -> b
forall a b. (a -> b) -> a -> b
$ EventF Arc t -> t
forall a b. EventF a b -> b
value EventF Arc t
ex))

applyPatToPatLeft :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatLeft :: forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatLeft Pattern (a -> b)
pf Pattern a
px = (State -> [Event b]) -> Pattern b
forall a. (State -> [Event a]) -> Pattern a
Pattern State -> [Event b]
q
    where q :: State -> [Event b]
q State
st = [Maybe (Event b)] -> [Event b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Event b)] -> [Event b]) -> [Maybe (Event b)] -> [Event b]
forall a b. (a -> b) -> a -> b
$ (EventF Arc (a -> b) -> [Maybe (Event b)])
-> [EventF Arc (a -> b)] -> [Maybe (Event b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc (a -> b) -> [Maybe (Event b)]
forall {b}. EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match ([EventF Arc (a -> b)] -> [Maybe (Event b)])
-> [EventF Arc (a -> b)] -> [Maybe (Event b)]
forall a b. (a -> b) -> a -> b
$ Pattern (a -> b) -> State -> [EventF Arc (a -> b)]
forall a. Pattern a -> State -> [Event a]
query Pattern (a -> b)
pf State
st
            where
              match :: EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match EventF Arc (a -> b)
ef = (EventF Arc a -> Maybe (EventF Arc b))
-> [EventF Arc a] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> [a] -> [b]
map (EventF Arc (a -> b) -> EventF Arc a -> Maybe (EventF Arc b)
forall {t} {b}.
EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
withFX EventF Arc (a -> b)
ef) (Pattern a -> State -> [EventF Arc a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
px (State -> [EventF Arc a]) -> State -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ State
st {arc :: Arc
arc = EventF Arc (a -> b) -> Arc
forall a. Event a -> Arc
wholeOrPart EventF Arc (a -> b)
ef})
              withFX :: EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
withFX EventF Arc (t -> b)
ef EventF Arc t
ex = do let whole' :: Maybe Arc
whole' = EventF Arc (t -> b) -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc (t -> b)
ef
                                Arc
part' <- Arc -> Arc -> Maybe Arc
subArc (EventF Arc (t -> b) -> Arc
forall a b. EventF a b -> a
part EventF Arc (t -> b)
ef) (EventF Arc t -> Arc
forall a b. EventF a b -> a
part EventF Arc t
ex)
                                EventF Arc b -> Maybe (EventF Arc b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts [EventF Arc (t -> b) -> Context
forall a b. EventF a b -> Context
context EventF Arc (t -> b)
ef, EventF Arc t -> Context
forall a b. EventF a b -> Context
context EventF Arc t
ex]) Maybe Arc
whole' Arc
part' (EventF Arc (t -> b) -> t -> b
forall a b. EventF a b -> b
value EventF Arc (t -> b)
ef (t -> b) -> t -> b
forall a b. (a -> b) -> a -> b
$ EventF Arc t -> t
forall a b. EventF a b -> b
value EventF Arc t
ex))

applyPatToPatRight :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatRight :: forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatRight Pattern (a -> b)
pf Pattern a
px = (State -> [Event b]) -> Pattern b
forall a. (State -> [Event a]) -> Pattern a
Pattern State -> [Event b]
q
    where q :: State -> [Event b]
q State
st = [Maybe (Event b)] -> [Event b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Event b)] -> [Event b]) -> [Maybe (Event b)] -> [Event b]
forall a b. (a -> b) -> a -> b
$ (EventF Arc a -> [Maybe (Event b)])
-> [EventF Arc a] -> [Maybe (Event b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc a -> [Maybe (Event b)]
match ([EventF Arc a] -> [Maybe (Event b)])
-> [EventF Arc a] -> [Maybe (Event b)]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [EventF Arc a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
px State
st
            where
              match :: EventF Arc a -> [Maybe (Event b)]
match EventF Arc a
ex = (EventF Arc (a -> b) -> Maybe (Event b))
-> [EventF Arc (a -> b)] -> [Maybe (Event b)]
forall a b. (a -> b) -> [a] -> [b]
map (EventF Arc (a -> b) -> EventF Arc a -> Maybe (Event b)
forall {t} {b}.
EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
`withFX` EventF Arc a
ex) (Pattern (a -> b) -> State -> [EventF Arc (a -> b)]
forall a. Pattern a -> State -> [Event a]
query Pattern (a -> b)
pf (State -> [EventF Arc (a -> b)]) -> State -> [EventF Arc (a -> b)]
forall a b. (a -> b) -> a -> b
$ State
st {arc :: Arc
arc = EventF Arc a -> Arc
forall a. Event a -> Arc
wholeOrPart EventF Arc a
ex})
              withFX :: EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
withFX EventF Arc (t -> b)
ef EventF Arc t
ex = do let whole' :: Maybe Arc
whole' = EventF Arc t -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc t
ex
                                Arc
part' <- Arc -> Arc -> Maybe Arc
subArc (EventF Arc (t -> b) -> Arc
forall a b. EventF a b -> a
part EventF Arc (t -> b)
ef) (EventF Arc t -> Arc
forall a b. EventF a b -> a
part EventF Arc t
ex)
                                EventF Arc b -> Maybe (EventF Arc b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts [EventF Arc (t -> b) -> Context
forall a b. EventF a b -> Context
context EventF Arc (t -> b)
ef, EventF Arc t -> Context
forall a b. EventF a b -> Context
context EventF Arc t
ex]) Maybe Arc
whole' Arc
part' (EventF Arc (t -> b) -> t -> b
forall a b. EventF a b -> b
value EventF Arc (t -> b)
ef (t -> b) -> t -> b
forall a b. (a -> b) -> a -> b
$ EventF Arc t -> t
forall a b. EventF a b -> b
value EventF Arc t
ex))

-- * Monad and friends

-- Note there are four ways of joining - the default 'unwrap' used by @>>=@, as well
-- as innerJoin, outerJoin and squeezeJoin.

instance Monad Pattern where
  return :: forall a. a -> Pattern a
return = a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Pattern a
p >>= :: forall a b. Pattern a -> (a -> Pattern b) -> Pattern b
>>= a -> Pattern b
f = Pattern (Pattern b) -> Pattern b
forall a. Pattern (Pattern a) -> Pattern a
unwrap (a -> Pattern b
f (a -> Pattern b) -> Pattern a -> Pattern (Pattern b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p)

-- | Turns a pattern of patterns into a single pattern.
-- (this is actually 'join')
--
-- 1/ For query 'arc', get the events from the outer pattern @pp@
-- 2/ Query the inner pattern using the 'part' of the outer
-- 3/ For each inner event, set the whole and part to be the intersection
--    of the outer whole and part, respectively
-- 4/ Concatenate all the events together (discarding wholes/parts that didn't intersect)
--
-- TODO - what if a continuous pattern contains a discrete one, or vice-versa?
unwrap :: Pattern (Pattern a) -> Pattern a
unwrap :: forall a. Pattern (Pattern a) -> Pattern a
unwrap Pattern (Pattern a)
pp = Pattern (Pattern a)
pp {query :: State -> [Event a]
query = State -> [Event a]
q}
  where q :: State -> [Event a]
q State
st = (EventF Arc (Pattern a) -> [Event a])
-> [EventF Arc (Pattern a)] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
          (\(Event Context
c Maybe Arc
w Arc
p Pattern a
v) ->
             (Event a -> Maybe (Event a)) -> [Event a] -> [Event a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> Maybe Arc -> Arc -> Event a -> Maybe (Event a)
forall {b}.
Context -> Maybe Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
c Maybe Arc
w Arc
p) ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
v State
st {arc :: Arc
arc = Arc
p})
          (Pattern (Pattern a) -> State -> [EventF Arc (Pattern a)]
forall a. Pattern a -> State -> [Event a]
query Pattern (Pattern a)
pp State
st)
        munge :: Context -> Maybe Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
oc Maybe Arc
ow Arc
op (Event Context
ic Maybe Arc
iw Arc
ip b
v') =
          do
            Maybe Arc
w' <- Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)
subMaybeArc Maybe Arc
ow Maybe Arc
iw
            Arc
p' <- Arc -> Arc -> Maybe Arc
subArc Arc
op Arc
ip
            EventF Arc b -> Maybe (EventF Arc b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts [Context
ic, Context
oc]) Maybe Arc
w' Arc
p' b
v')

-- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
-- but structure only comes from the inner pattern.
innerJoin :: Pattern (Pattern a) -> Pattern a
innerJoin :: forall a. Pattern (Pattern a) -> Pattern a
innerJoin Pattern (Pattern a)
pp = Pattern (Pattern a)
pp {query :: State -> [Event a]
query = State -> [Event a]
q}
  where q :: State -> [Event a]
q State
st = (EventF Arc (Pattern a) -> [Event a])
-> [EventF Arc (Pattern a)] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
               (\(Event Context
oc Maybe Arc
_ Arc
op Pattern a
v) -> (Event a -> Maybe (Event a)) -> [Event a] -> [Event a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> Event a -> Maybe (Event a)
forall {b}. Context -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
oc) ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
v State
st {arc :: Arc
arc = Arc
op}
          )
          (Pattern (Pattern a) -> State -> [EventF Arc (Pattern a)]
forall a. Pattern a -> State -> [Event a]
query Pattern (Pattern a)
pp State
st)
          where munge :: Context -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
oc (Event Context
ic Maybe Arc
iw Arc
ip b
v) =
                  do
                    Arc
p <- Arc -> Arc -> Maybe Arc
subArc (State -> Arc
arc State
st) Arc
ip
                    Arc
p' <- Arc -> Arc -> Maybe Arc
subArc Arc
p (State -> Arc
arc State
st)
                    EventF Arc b -> Maybe (EventF Arc b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts [Context
ic, Context
oc]) Maybe Arc
iw Arc
p' b
v)

-- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
-- but structure only comes from the outer pattern.
outerJoin :: Pattern (Pattern a) -> Pattern a
outerJoin :: forall a. Pattern (Pattern a) -> Pattern a
outerJoin Pattern (Pattern a)
pp = Pattern (Pattern a)
pp {query :: State -> [Event a]
query = State -> [Event a]
q}
  where q :: State -> [Event a]
q State
st = (EventF Arc (Pattern a) -> [Event a])
-> [EventF Arc (Pattern a)] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
          (\EventF Arc (Pattern a)
e ->
             (Event a -> Maybe (Event a)) -> [Event a] -> [Event a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> Maybe Arc -> Arc -> Event a -> Maybe (Event a)
forall {a} {b}.
Context -> Maybe Arc -> Arc -> EventF a b -> Maybe (EventF Arc b)
munge (EventF Arc (Pattern a) -> Context
forall a b. EventF a b -> Context
context EventF Arc (Pattern a)
e) (EventF Arc (Pattern a) -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc (Pattern a)
e) (EventF Arc (Pattern a) -> Arc
forall a b. EventF a b -> a
part EventF Arc (Pattern a)
e)) ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query (EventF Arc (Pattern a) -> Pattern a
forall a b. EventF a b -> b
value EventF Arc (Pattern a)
e) State
st {arc :: Arc
arc = Rational -> Arc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arc -> Rational
forall a. ArcF a -> a
start (Arc -> Rational) -> Arc -> Rational
forall a b. (a -> b) -> a -> b
$ EventF Arc (Pattern a) -> Arc
forall a. Event a -> Arc
wholeOrPart EventF Arc (Pattern a)
e)}
          )
          (Pattern (Pattern a) -> State -> [EventF Arc (Pattern a)]
forall a. Pattern a -> State -> [Event a]
query Pattern (Pattern a)
pp State
st)
          where munge :: Context -> Maybe Arc -> Arc -> EventF a b -> Maybe (EventF Arc b)
munge Context
oc Maybe Arc
ow Arc
op (Event Context
ic Maybe a
_ a
_ b
v') =
                  do
                    Arc
p' <- Arc -> Arc -> Maybe Arc
subArc (State -> Arc
arc State
st) Arc
op
                    EventF Arc b -> Maybe (EventF Arc b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts [Context
oc, Context
ic]) Maybe Arc
ow Arc
p' b
v')

-- | Like @unwrap@, but cycles of the inner patterns are compressed to fit the
-- timespan of the outer whole (or the original query if it's a continuous pattern?)
-- TODO - what if a continuous pattern contains a discrete one, or vice-versa?
squeezeJoin :: Pattern (Pattern a) -> Pattern a
squeezeJoin :: forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin Pattern (Pattern a)
pp = Pattern (Pattern a)
pp {query :: State -> [Event a]
query = State -> [Event a]
q}
  where q :: State -> [Event a]
q State
st = (EventF Arc (Pattern a) -> [Event a])
-> [EventF Arc (Pattern a)] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
          (\e :: EventF Arc (Pattern a)
e@(Event Context
c Maybe Arc
w Arc
p Pattern a
v) ->
             (Event a -> Maybe (Event a)) -> [Event a] -> [Event a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> Maybe Arc -> Arc -> Event a -> Maybe (Event a)
forall {b}.
Context -> Maybe Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
c Maybe Arc
w Arc
p) ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query (Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
compressArc (Arc -> Arc
cycleArc (Arc -> Arc) -> Arc -> Arc
forall a b. (a -> b) -> a -> b
$ EventF Arc (Pattern a) -> Arc
forall a. Event a -> Arc
wholeOrPart EventF Arc (Pattern a)
e) Pattern a
v) State
st {arc :: Arc
arc = Arc
p}
          )
          (Pattern (Pattern a) -> State -> [EventF Arc (Pattern a)]
forall a. Pattern a -> State -> [Event a]
query Pattern (Pattern a)
pp State
st)
        munge :: Context -> Maybe Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
oContext Maybe Arc
oWhole Arc
oPart (Event Context
iContext Maybe Arc
iWhole Arc
iPart b
v) =
          do Maybe Arc
w' <- Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)
subMaybeArc Maybe Arc
oWhole Maybe Arc
iWhole
             Arc
p' <- Arc -> Arc -> Maybe Arc
subArc Arc
oPart Arc
iPart
             EventF Arc b -> Maybe (EventF Arc b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts [Context
iContext, Context
oContext]) Maybe Arc
w' Arc
p' b
v)

-- | * Patterns as numbers

noOv :: String -> a
noOv :: forall a. String -> a
noOv String
meth = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
meth String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": not supported for patterns"

instance Eq (Pattern a) where
  == :: Pattern a -> Pattern a -> Bool
(==) = String -> Pattern a -> Pattern a -> Bool
forall a. String -> a
noOv String
"(==)"

instance Ord a => Ord (Pattern a) where
  min :: Pattern a -> Pattern a -> Pattern a
min = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Ord a => a -> a -> a
min
  max :: Pattern a -> Pattern a -> Pattern a
max = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Ord a => a -> a -> a
max
  compare :: Pattern a -> Pattern a -> Ordering
compare = String -> Pattern a -> Pattern a -> Ordering
forall a. String -> a
noOv String
"compare"
  <= :: Pattern a -> Pattern a -> Bool
(<=) = String -> Pattern a -> Pattern a -> Bool
forall a. String -> a
noOv String
"(<=)"

instance Num a => Num (Pattern a) where
  negate :: Pattern a -> Pattern a
negate      = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Num a => a -> a
negate
  + :: Pattern a -> Pattern a -> Pattern a
(+)         = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Num a => a -> a -> a
(+)
  * :: Pattern a -> Pattern a -> Pattern a
(*)         = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Num a => a -> a -> a
(*)
  fromInteger :: Integer -> Pattern a
fromInteger = a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Pattern a) -> (Integer -> a) -> Integer -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger
  abs :: Pattern a -> Pattern a
abs         = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Num a => a -> a
abs
  signum :: Pattern a -> Pattern a
signum      = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Num a => a -> a
signum

instance Enum a => Enum (Pattern a) where
  succ :: Pattern a -> Pattern a
succ           = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Enum a => a -> a
succ
  pred :: Pattern a -> Pattern a
pred           = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Enum a => a -> a
pred
  toEnum :: Int -> Pattern a
toEnum         = a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Pattern a) -> (Int -> a) -> Int -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
forall a. Enum a => Int -> a
toEnum
  fromEnum :: Pattern a -> Int
fromEnum       = String -> Pattern a -> Int
forall a. String -> a
noOv String
"fromEnum"
  enumFrom :: Pattern a -> [Pattern a]
enumFrom       = String -> Pattern a -> [Pattern a]
forall a. String -> a
noOv String
"enumFrom"
  enumFromThen :: Pattern a -> Pattern a -> [Pattern a]
enumFromThen   = String -> Pattern a -> Pattern a -> [Pattern a]
forall a. String -> a
noOv String
"enumFromThen"
  enumFromTo :: Pattern a -> Pattern a -> [Pattern a]
enumFromTo     = String -> Pattern a -> Pattern a -> [Pattern a]
forall a. String -> a
noOv String
"enumFromTo"
  enumFromThenTo :: Pattern a -> Pattern a -> Pattern a -> [Pattern a]
enumFromThenTo = String -> Pattern a -> Pattern a -> Pattern a -> [Pattern a]
forall a. String -> a
noOv String
"enumFromThenTo"

instance Monoid (Pattern a) where
  mempty :: Pattern a
mempty = Pattern a
forall a. Pattern a
empty

instance Semigroup (Pattern a) where
  <> :: Pattern a -> Pattern a -> Pattern a
(<>) !Pattern a
p !Pattern a
p' = (State -> [Event a]) -> Pattern a
forall a. (State -> [Event a]) -> Pattern a
Pattern ((State -> [Event a]) -> Pattern a)
-> (State -> [Event a]) -> Pattern a
forall a b. (a -> b) -> a -> b
$ \State
st -> Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
p State
st [Event a] -> [Event a] -> [Event a]
forall a. [a] -> [a] -> [a]
++ Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
p' State
st

instance (Num a, Ord a) => Real (Pattern a) where
  toRational :: Pattern a -> Rational
toRational = String -> Pattern a -> Rational
forall a. String -> a
noOv String
"toRational"

instance (Integral a) => Integral (Pattern a) where
  quot :: Pattern a -> Pattern a -> Pattern a
quot          = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Integral a => a -> a -> a
quot
  rem :: Pattern a -> Pattern a -> Pattern a
rem           = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Integral a => a -> a -> a
rem
  div :: Pattern a -> Pattern a -> Pattern a
div           = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Integral a => a -> a -> a
div
  mod :: Pattern a -> Pattern a -> Pattern a
mod           = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Integral a => a -> a -> a
mod
  toInteger :: Pattern a -> Integer
toInteger     = String -> Pattern a -> Integer
forall a. String -> a
noOv String
"toInteger"
  Pattern a
x quotRem :: Pattern a -> Pattern a -> (Pattern a, Pattern a)
`quotRem` Pattern a
y = (Pattern a
x Pattern a -> Pattern a -> Pattern a
forall a. Integral a => a -> a -> a
`quot` Pattern a
y, Pattern a
x Pattern a -> Pattern a -> Pattern a
forall a. Integral a => a -> a -> a
`rem` Pattern a
y)
  Pattern a
x divMod :: Pattern a -> Pattern a -> (Pattern a, Pattern a)
`divMod`  Pattern a
y = (Pattern a
x Pattern a -> Pattern a -> Pattern a
forall a. Integral a => a -> a -> a
`div`  Pattern a
y, Pattern a
x Pattern a -> Pattern a -> Pattern a
forall a. Integral a => a -> a -> a
`mod` Pattern a
y)

instance (Fractional a) => Fractional (Pattern a) where
  recip :: Pattern a -> Pattern a
recip        = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Fractional a => a -> a
recip
  fromRational :: Rational -> Pattern a
fromRational = a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Pattern a) -> (Rational -> a) -> Rational -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> a
forall a. Fractional a => Rational -> a
fromRational

instance (Floating a) => Floating (Pattern a) where
  pi :: Pattern a
pi    = a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Floating a => a
pi
  sqrt :: Pattern a -> Pattern a
sqrt  = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
sqrt
  exp :: Pattern a -> Pattern a
exp   = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
exp
  log :: Pattern a -> Pattern a
log   = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
log
  sin :: Pattern a -> Pattern a
sin   = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
sin
  cos :: Pattern a -> Pattern a
cos   = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
cos
  asin :: Pattern a -> Pattern a
asin  = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
asin
  atan :: Pattern a -> Pattern a
atan  = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
atan
  acos :: Pattern a -> Pattern a
acos  = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
acos
  sinh :: Pattern a -> Pattern a
sinh  = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
sinh
  cosh :: Pattern a -> Pattern a
cosh  = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
cosh
  asinh :: Pattern a -> Pattern a
asinh = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
asinh
  atanh :: Pattern a -> Pattern a
atanh = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
atanh
  acosh :: Pattern a -> Pattern a
acosh = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Floating a => a -> a
acosh

instance (RealFrac a) => RealFrac (Pattern a) where
  properFraction :: forall b. Integral b => Pattern a -> (b, Pattern a)
properFraction = String -> Pattern a -> (b, Pattern a)
forall a. String -> a
noOv String
"properFraction"
  truncate :: forall b. Integral b => Pattern a -> b
truncate       = String -> Pattern a -> b
forall a. String -> a
noOv String
"truncate"
  round :: forall b. Integral b => Pattern a -> b
round          = String -> Pattern a -> b
forall a. String -> a
noOv String
"round"
  ceiling :: forall b. Integral b => Pattern a -> b
ceiling        = String -> Pattern a -> b
forall a. String -> a
noOv String
"ceiling"
  floor :: forall b. Integral b => Pattern a -> b
floor          = String -> Pattern a -> b
forall a. String -> a
noOv String
"floor"

instance (RealFloat a) => RealFloat (Pattern a) where
  floatRadix :: Pattern a -> Integer
floatRadix     = String -> Pattern a -> Integer
forall a. String -> a
noOv String
"floatRadix"
  floatDigits :: Pattern a -> Int
floatDigits    = String -> Pattern a -> Int
forall a. String -> a
noOv String
"floatDigits"
  floatRange :: Pattern a -> (Int, Int)
floatRange     = String -> Pattern a -> (Int, Int)
forall a. String -> a
noOv String
"floatRange"
  decodeFloat :: Pattern a -> (Integer, Int)
decodeFloat    = String -> Pattern a -> (Integer, Int)
forall a. String -> a
noOv String
"decodeFloat"
  encodeFloat :: Integer -> Int -> Pattern a
encodeFloat    = (((Int -> a) -> Int -> Pattern a)
-> (Integer -> Int -> a) -> Integer -> Int -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)(((Int -> a) -> Int -> Pattern a)
 -> (Integer -> Int -> a) -> Integer -> Int -> Pattern a)
-> ((a -> Pattern a) -> (Int -> a) -> Int -> Pattern a)
-> (a -> Pattern a)
-> (Integer -> Int -> a)
-> Integer
-> Int
-> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Pattern a) -> (Int -> a) -> Int -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat
  exponent :: Pattern a -> Int
exponent       = String -> Pattern a -> Int
forall a. String -> a
noOv String
"exponent"
  significand :: Pattern a -> Pattern a
significand    = String -> Pattern a -> Pattern a
forall a. String -> a
noOv String
"significand"
  scaleFloat :: Int -> Pattern a -> Pattern a
scaleFloat Int
n   = (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> a -> a
forall a. RealFloat a => Int -> a -> a
scaleFloat Int
n)
  isNaN :: Pattern a -> Bool
isNaN          = String -> Pattern a -> Bool
forall a. String -> a
noOv String
"isNaN"
  isInfinite :: Pattern a -> Bool
isInfinite     = String -> Pattern a -> Bool
forall a. String -> a
noOv String
"isInfinite"
  isDenormalized :: Pattern a -> Bool
isDenormalized = String -> Pattern a -> Bool
forall a. String -> a
noOv String
"isDenormalized"
  isNegativeZero :: Pattern a -> Bool
isNegativeZero = String -> Pattern a -> Bool
forall a. String -> a
noOv String
"isNegativeZero"
  isIEEE :: Pattern a -> Bool
isIEEE         = String -> Pattern a -> Bool
forall a. String -> a
noOv String
"isIEEE"
  atan2 :: Pattern a -> Pattern a -> Pattern a
atan2          = (a -> a -> a) -> Pattern a -> Pattern a -> Pattern a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. RealFloat a => a -> a -> a
atan2

instance Num ValueMap where
  negate :: ValueMap -> ValueMap
negate      = ((Double -> Double)
-> (Int -> Int) -> (String -> String) -> Value -> Value
applyFIS Double -> Double
forall a. Num a => a -> a
negate Int -> Int
forall a. Num a => a -> a
negate String -> String
forall a. a -> a
id (Value -> Value) -> ValueMap -> ValueMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  + :: ValueMap -> ValueMap -> ValueMap
(+)         = (Value -> Value -> Value) -> ValueMap -> ValueMap -> ValueMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((Int -> Int -> Int)
-> (Double -> Double -> Double) -> Value -> Value -> Value
fNum2 Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Double -> Double -> Double
forall a. Num a => a -> a -> a
(+))
  * :: ValueMap -> ValueMap -> ValueMap
(*)         = (Value -> Value -> Value) -> ValueMap -> ValueMap -> ValueMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((Int -> Int -> Int)
-> (Double -> Double -> Double) -> Value -> Value -> Value
fNum2 Int -> Int -> Int
forall a. Num a => a -> a -> a
(*) Double -> Double -> Double
forall a. Num a => a -> a -> a
(*))
  fromInteger :: Integer -> ValueMap
fromInteger Integer
i = String -> Value -> ValueMap
forall k a. k -> a -> Map k a
Map.singleton String
"n" (Value -> ValueMap) -> Value -> ValueMap
forall a b. (a -> b) -> a -> b
$ Int -> Value
VI (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
  signum :: ValueMap -> ValueMap
signum      = ((Double -> Double)
-> (Int -> Int) -> (String -> String) -> Value -> Value
applyFIS Double -> Double
forall a. Num a => a -> a
signum Int -> Int
forall a. Num a => a -> a
signum String -> String
forall a. a -> a
id (Value -> Value) -> ValueMap -> ValueMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  abs :: ValueMap -> ValueMap
abs         = ((Double -> Double)
-> (Int -> Int) -> (String -> String) -> Value -> Value
applyFIS Double -> Double
forall a. Num a => a -> a
abs Int -> Int
forall a. Num a => a -> a
abs String -> String
forall a. a -> a
id (Value -> Value) -> ValueMap -> ValueMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

instance Fractional ValueMap where
  recip :: ValueMap -> ValueMap
recip        = (Value -> Value) -> ValueMap -> ValueMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Double -> Double)
-> (Int -> Int) -> (String -> String) -> Value -> Value
applyFIS Double -> Double
forall a. Fractional a => a -> a
recip Int -> Int
forall a. a -> a
id String -> String
forall a. a -> a
id)
  fromRational :: Rational -> ValueMap
fromRational Rational
r = String -> Value -> ValueMap
forall k a. k -> a -> Map k a
Map.singleton String
"speed" (Value -> ValueMap) -> Value -> ValueMap
forall a b. (a -> b) -> a -> b
$ Double -> Value
VF (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)

class Moddable a where
  gmod :: a -> a -> a

instance Moddable Double where
  gmod :: Double -> Double -> Double
gmod = Double -> Double -> Double
forall a. Real a => a -> a -> a
mod'
instance Moddable Rational where
  gmod :: Rational -> Rational -> Rational
gmod = Rational -> Rational -> Rational
forall a. Real a => a -> a -> a
mod'
instance Moddable Note where
  gmod :: Note -> Note -> Note
gmod (Note Double
a) (Note Double
b) = Double -> Note
Note (Double -> Double -> Double
forall a. Real a => a -> a -> a
mod' Double
a Double
b)
instance Moddable Int where
  gmod :: Int -> Int -> Int
gmod = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod
instance Moddable ValueMap where
  gmod :: ValueMap -> ValueMap -> ValueMap
gmod = (Value -> Value -> Value) -> ValueMap -> ValueMap -> ValueMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((Int -> Int -> Int)
-> (Double -> Double -> Double) -> Value -> Value -> Value
fNum2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Double -> Double -> Double
forall a. Real a => a -> a -> a
mod')

instance Floating ValueMap
  where pi :: ValueMap
pi = String -> ValueMap
forall a. String -> a
noOv String
"pi"
        exp :: ValueMap -> ValueMap
exp ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"exp"
        log :: ValueMap -> ValueMap
log ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"log"
        sin :: ValueMap -> ValueMap
sin ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"sin"
        cos :: ValueMap -> ValueMap
cos ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"cos"
        asin :: ValueMap -> ValueMap
asin ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"asin"
        acos :: ValueMap -> ValueMap
acos ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"acos"
        atan :: ValueMap -> ValueMap
atan ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"atan"
        sinh :: ValueMap -> ValueMap
sinh ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"sinh"
        cosh :: ValueMap -> ValueMap
cosh ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"cosh"
        asinh :: ValueMap -> ValueMap
asinh ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"asinh"
        acosh :: ValueMap -> ValueMap
acosh ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"acosh"
        atanh :: ValueMap -> ValueMap
atanh ValueMap
_ = String -> ValueMap
forall a. String -> a
noOv String
"atanh"

------------------------------------------------------------------------
-- * Internal functions

empty :: Pattern a
empty :: forall a. Pattern a
empty = Pattern :: forall a. (State -> [Event a]) -> Pattern a
Pattern {query :: State -> [Event a]
query = [Event a] -> State -> [Event a]
forall a b. a -> b -> a
const []}

queryArc :: Pattern a -> Arc -> [Event a]
queryArc :: forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern a
p Arc
a = Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
p (State -> [Event a]) -> State -> [Event a]
forall a b. (a -> b) -> a -> b
$ Arc -> ValueMap -> State
State Arc
a ValueMap
forall k a. Map k a
Map.empty 

-- | Splits queries that span cycles. For example `query p (0.5, 1.5)` would be
-- turned into two queries, `(0.5,1)` and `(1,1.5)`, and the results
-- combined. Being able to assume queries don't span cycles often
-- makes transformations easier to specify.
splitQueries