{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Sound.Tidal.Pattern where

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

import           Control.Applicative (liftA2)
--import           Data.Bifunctor (Bifunctor(..))
import           Data.Data (Data) -- toConstr
import           GHC.Generics
import           Data.List (delete, findIndex, sort)
import qualified Data.Map.Strict as Map
import           Data.Maybe (isJust, fromJust, catMaybes, mapMaybe)
import           Data.Typeable (Typeable)
import           Control.DeepSeq (NFData(rnf))
import           Data.Word (Word8)

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

-- | Time is rational
type Time = Rational 

-- | The 'sam' (start of cycle) for the given time value
sam :: Time -> Time
sam :: Time -> Time
sam = Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Time) -> (Time -> Int) -> Time -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor :: Time -> Int)

-- | Turns a number into a (rational) time value. An alias for 'toRational'.
toTime :: Real a => a -> Rational
toTime :: a -> Time
toTime = a -> Time
forall a. Real a => a -> Time
toRational

-- | The end point of the current cycle (and starting point of the next cycle)
nextSam :: Time -> Time
nextSam :: Time -> Time
nextSam = (1Time -> Time -> Time
forall a. Num a => a -> a -> a
+) (Time -> Time) -> (Time -> Time) -> Time -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> Time
sam

-- | The position of a time value relative to the start of its cycle.
cyclePos :: Time -> Time
cyclePos :: Time -> Time
cyclePos t :: Time
t = Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time -> Time
sam Time
t

-- | An arc of time, with a start time (or onset) and a stop time (or offset)
data ArcF a = Arc
  { ArcF a -> a
start :: a
  , ArcF a -> a
stop :: a
  } deriving (ArcF a -> ArcF a -> Bool
(ArcF a -> ArcF a -> Bool)
-> (ArcF a -> ArcF a -> Bool) -> Eq (ArcF a)
forall a. Eq a => ArcF a -> ArcF a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArcF a -> ArcF a -> Bool
$c/= :: forall a. Eq a => ArcF a -> ArcF a -> Bool
== :: ArcF a -> ArcF a -> Bool
$c== :: forall a. Eq a => ArcF a -> ArcF a -> Bool
Eq, Eq (ArcF a)
Eq (ArcF a) =>
(ArcF a -> ArcF a -> Ordering)
-> (ArcF a -> ArcF a -> Bool)
-> (ArcF a -> ArcF a -> Bool)
-> (ArcF a -> ArcF a -> Bool)
-> (ArcF a -> ArcF a -> Bool)
-> (ArcF a -> ArcF a -> ArcF a)
-> (ArcF a -> ArcF a -> ArcF a)
-> Ord (ArcF a)
ArcF a -> ArcF a -> Bool
ArcF a -> ArcF a -> Ordering
ArcF a -> ArcF a -> ArcF a
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
forall a. Ord a => Eq (ArcF a)
forall a. Ord a => ArcF a -> ArcF a -> Bool
forall a. Ord a => ArcF a -> ArcF a -> Ordering
forall a. Ord a => ArcF a -> ArcF a -> ArcF a
min :: ArcF a -> ArcF a -> ArcF a
$cmin :: forall a. Ord a => ArcF a -> ArcF a -> ArcF a
max :: ArcF a -> ArcF a -> ArcF a
$cmax :: forall a. Ord a => ArcF a -> ArcF a -> ArcF a
>= :: ArcF a -> ArcF a -> Bool
$c>= :: forall a. Ord a => ArcF a -> ArcF a -> Bool
> :: ArcF a -> ArcF a -> Bool
$c> :: forall a. Ord a => ArcF a -> ArcF a -> Bool
<= :: ArcF a -> ArcF a -> Bool
$c<= :: forall a. Ord a => ArcF a -> ArcF a -> Bool
< :: ArcF a -> ArcF a -> Bool
$c< :: forall a. Ord a => ArcF a -> ArcF a -> Bool
compare :: ArcF a -> ArcF a -> Ordering
$ccompare :: forall a. Ord a => ArcF a -> ArcF a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (ArcF a)
Ord, a -> ArcF b -> ArcF a
(a -> b) -> ArcF a -> ArcF b
(forall a b. (a -> b) -> ArcF a -> ArcF b)
-> (forall a b. a -> ArcF b -> ArcF a) -> Functor ArcF
forall a b. a -> ArcF b -> ArcF a
forall a b. (a -> b) -> ArcF a -> ArcF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ArcF b -> ArcF a
$c<$ :: forall a b. a -> ArcF b -> ArcF a
fmap :: (a -> b) -> ArcF a -> ArcF b
$cfmap :: forall a b. (a -> b) -> ArcF a -> ArcF b
Functor, Int -> ArcF a -> ShowS
[ArcF a] -> ShowS
ArcF a -> String
(Int -> ArcF a -> ShowS)
-> (ArcF a -> String) -> ([ArcF a] -> ShowS) -> Show (ArcF a)
forall a. Show a => Int -> ArcF a -> ShowS
forall a. Show a => [ArcF a] -> ShowS
forall a. Show a => ArcF a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArcF a] -> ShowS
$cshowList :: forall a. Show a => [ArcF a] -> ShowS
show :: ArcF a -> String
$cshow :: forall a. Show a => ArcF a -> String
showsPrec :: Int -> ArcF a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ArcF a -> ShowS
Show, (forall x. ArcF a -> Rep (ArcF a) x)
-> (forall x. Rep (ArcF a) x -> ArcF a) -> Generic (ArcF a)
forall x. Rep (ArcF a) x -> ArcF a
forall x. ArcF a -> Rep (ArcF a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ArcF a) x -> ArcF a
forall a x. ArcF a -> Rep (ArcF a) x
$cto :: forall a x. Rep (ArcF a) x -> ArcF a
$cfrom :: forall a x. ArcF a -> Rep (ArcF a) x
Generic)

type Arc = ArcF Time

instance NFData a => NFData (ArcF a)

instance Num a => Num (ArcF a) where
  negate :: ArcF a -> ArcF a
negate      = (a -> a) -> ArcF a -> ArcF a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Num a => a -> a
negate
  + :: ArcF a -> ArcF a -> ArcF a
(+)         = (a -> a -> a) -> ArcF a -> ArcF a -> ArcF 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
(+)
  * :: ArcF a -> ArcF a -> ArcF a
(*)         = (a -> a -> a) -> ArcF a -> ArcF a -> ArcF 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 -> ArcF a
fromInteger = a -> ArcF a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ArcF a) -> (Integer -> a) -> Integer -> ArcF a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger
  abs :: ArcF a -> ArcF a
abs         = (a -> a) -> ArcF a -> ArcF a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Num a => a -> a
abs
  signum :: ArcF a -> ArcF a
signum      = (a -> a) -> ArcF a -> ArcF a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Num a => a -> a
signum

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

sect :: Arc -> Arc -> Arc
sect :: Arc -> Arc -> Arc
sect (Arc s :: Time
s e :: Time
e) (Arc s' :: Time
s' e' :: Time
e') = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
s Time
s') (Time -> Time -> Time
forall a. Ord a => a -> a -> a
min Time
e Time
e')

-- | convex hull union
hull :: Arc -> Arc -> Arc
hull :: Arc -> Arc -> Arc
hull (Arc s :: Time
s e :: Time
e) (Arc s' :: Time
s' e' :: Time
e') = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time -> Time
forall a. Ord a => a -> a -> a
min Time
s Time
s') (Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
e Time
e')

-- | @subArc i j@ is the timespan that is the intersection of @i@ and @j@.
-- intersection
-- The definition is a bit fiddly as results might be zero-width, but
-- not at the end of an non-zero-width arc - e.g. (0,1) and (1,2) do
-- not intersect, but (1,1) (1,1) does.
subArc :: Arc -> Arc -> Maybe Arc
subArc :: Arc -> Arc -> Maybe Arc
subArc a :: Arc
a@(Arc s :: Time
s e :: Time
e) b :: Arc
b@(Arc s' :: Time
s' e' :: Time
e')
  | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Time
s'' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
e'', Time
s'' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
e, Time
s Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
e] = Maybe Arc
forall a. Maybe a
Nothing
  | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Time
s'' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
e'', Time
s'' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
e', Time
s' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
e'] = Maybe Arc
forall a. Maybe a
Nothing
  | Time
s'' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
e'' = Arc -> Maybe Arc
forall a. a -> Maybe a
Just (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s'' Time
e'')
  | Bool
otherwise = Maybe Arc
forall a. Maybe a
Nothing
  where (Arc s'' :: Time
s'' e'' :: Time
e'') = Arc -> Arc -> Arc
sect Arc
a Arc
b

subMaybeArc :: Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)
subMaybeArc :: Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)
subMaybeArc (Just a :: Arc
a) (Just b :: Arc
b) = do Arc
sa <- Arc -> Arc -> Maybe Arc
subArc Arc
a Arc
b
                                   Maybe Arc -> Maybe (Maybe Arc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Arc -> Maybe (Maybe Arc)) -> Maybe Arc -> Maybe (Maybe Arc)
forall a b. (a -> b) -> a -> b
$ Arc -> Maybe Arc
forall a. a -> Maybe a
Just Arc
sa
subMaybeArc _ _ = Maybe Arc -> Maybe (Maybe Arc)
forall a. a -> Maybe a
Just Maybe Arc
forall a. Maybe a
Nothing

instance Applicative ArcF where
  pure :: a -> ArcF a
pure t :: a
t = a -> a -> ArcF a
forall a. a -> a -> ArcF a
Arc a
t a
t
  <*> :: ArcF (a -> b) -> ArcF a -> ArcF b
(<*>) (Arc sf :: a -> b
sf ef :: a -> b
ef) (Arc sx :: a
sx ex :: a
ex) = b -> b -> ArcF b
forall a. a -> a -> ArcF a
Arc (a -> b
sf a
sx) (a -> b
ef a
ex)

-- | The arc of the whole cycle that the given time value falls within
timeToCycleArc :: Time -> Arc
timeToCycleArc :: Time -> Arc
timeToCycleArc t :: Time
t = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
sam Time
t) (Time -> Time
sam Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ 1)

-- | Shifts an arc to the equivalent one that starts during cycle zero
cycleArc :: Arc -> Arc
cycleArc :: Arc -> Arc
cycleArc (Arc s :: Time
s e :: Time
e) = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
cyclePos Time
s) (Time -> Time
cyclePos Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
+ (Time
eTime -> Time -> Time
forall a. Num a => a -> a -> a
-Time
s))

-- | A list of cycle numbers which are included in the given arc
cyclesInArc :: Integral a => Arc -> [a]
cyclesInArc :: Arc -> [a]
cyclesInArc (Arc s :: Time
s e :: Time
e)
  | Time
s Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
e = []
  | Time
s Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
e = [Time -> a
forall a b. (RealFrac a, Integral b) => a -> b
floor Time
s]
  | Bool
otherwise = [Time -> a
forall a b. (RealFrac a, Integral b) => a -> b
floor Time
s .. Time -> a
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Time
ea -> a -> a
forall a. Num a => a -> a -> a
-1]

-- | A list of arcs of the whole cycles which are included in the given arc
cycleArcsInArc :: Arc -> [Arc]
cycleArcsInArc :: Arc -> [Arc]
cycleArcsInArc = (Int -> Arc) -> [Int] -> [Arc]
forall a b. (a -> b) -> [a] -> [b]
map (Time -> Arc
timeToCycleArc (Time -> Arc) -> (Int -> Time) -> Int -> Arc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Time
forall a. Real a => a -> Time
toTime :: Int -> Time)) ([Int] -> [Arc]) -> (Arc -> [Int]) -> Arc -> [Arc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arc -> [Int]
forall a. Integral a => Arc -> [a]
cyclesInArc

-- | Splits the given 'Arc' into a list of 'Arc's, at cycle boundaries.
arcCycles :: Arc -> [Arc]
arcCycles :: Arc -> [Arc]
arcCycles (Arc s :: Time
s e :: Time
e) | Time
s Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
e = []
                | Time -> Time
sam Time
s Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time -> Time
sam Time
e = [Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s Time
e]
                | Bool
otherwise = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s (Time -> Time
nextSam Time
s) Arc -> [Arc] -> [Arc]
forall a. a -> [a] -> [a]
: Arc -> [Arc]
arcCycles (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
nextSam Time
s) Time
e)

-- | Like arcCycles, but returns zero-width arcs
arcCyclesZW :: Arc -> [Arc]
arcCyclesZW :: Arc -> [Arc]
arcCyclesZW (Arc s :: Time
s e :: Time
e) | Time
s Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
e = [Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s Time
e]
                  | Bool
otherwise = Arc -> [Arc]
arcCycles (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s Time
e)

-- | Similar to 'fmap' but time is relative to the cycle (i.e. the
-- sam of the start of the arc)
mapCycle :: (Time -> Time) -> Arc -> Arc
mapCycle :: (Time -> Time) -> Arc -> Arc
mapCycle f :: Time -> Time
f (Arc s :: Time
s e :: Time
e) = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time
sam' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> Time
f (Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
sam')) (Time
sam' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> Time
f (Time
e Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
sam'))
         where sam' :: Time
sam' = Time -> Time
sam Time
s

-- | @isIn a t@ is @True@ if @t@ is inside
-- the arc represented by @a@.
isIn :: Arc -> Time -> Bool
isIn :: Arc -> Time -> Bool
isIn (Arc s :: Time
s e :: Time
e) t :: Time
t = Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
s Bool -> Bool -> Bool
&& Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
e

data Context = Context {Context -> [((Int, Int), (Int, Int))]
contextPosition :: [((Int, Int), (Int, Int))]}
  deriving (Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq, Eq Context
Eq Context =>
(Context -> Context -> Ordering)
-> (Context -> Context -> Bool)
-> (Context -> Context -> Bool)
-> (Context -> Context -> Bool)
-> (Context -> Context -> Bool)
-> (Context -> Context -> Context)
-> (Context -> Context -> Context)
-> Ord Context
Context -> Context -> Bool
Context -> Context -> Ordering
Context -> Context -> Context
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 :: Context -> Context -> Context
$cmin :: Context -> Context -> Context
max :: Context -> Context -> Context
$cmax :: Context -> Context -> Context
>= :: Context -> Context -> Bool
$c>= :: Context -> Context -> Bool
> :: Context -> Context -> Bool
$c> :: Context -> Context -> Bool
<= :: Context -> Context -> Bool
$c<= :: Context -> Context -> Bool
< :: Context -> Context -> Bool
$c< :: Context -> Context -> Bool
compare :: Context -> Context -> Ordering
$ccompare :: Context -> Context -> Ordering
$cp1Ord :: Eq Context
Ord, (forall x. Context -> Rep Context x)
-> (forall x. Rep Context x -> Context) -> Generic Context
forall x. Rep Context x -> Context
forall x. Context -> Rep Context x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Context x -> Context
$cfrom :: forall x. Context -> Rep Context x
Generic)

instance NFData Context

combineContexts :: [Context] -> Context
combineContexts :: [Context] -> Context
combineContexts = [((Int, Int), (Int, Int))] -> Context
Context ([((Int, Int), (Int, Int))] -> Context)
-> ([Context] -> [((Int, Int), (Int, Int))])
-> [Context]
-> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context -> [((Int, Int), (Int, Int))])
-> [Context] -> [((Int, Int), (Int, Int))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Context -> [((Int, Int), (Int, Int))]
contextPosition

setContext :: Context -> Pattern a -> Pattern a
setContext :: Context -> Pattern a -> Pattern a
setContext c :: Context
c pat :: Pattern a
pat = ([Event a] -> [Event a]) -> Pattern a -> Pattern a
forall a b. ([Event a] -> [Event b]) -> Pattern a -> Pattern b
withEvents ((Event a -> Event a) -> [Event a] -> [Event a]
forall a b. (a -> b) -> [a] -> [b]
map (\e :: Event a
e -> Event a
e {context :: Context
context = Context
c})) Pattern a
pat

withContext :: (Context -> Context) -> Pattern a -> Pattern a
withContext :: (Context -> Context) -> Pattern a -> Pattern a
withContext f :: Context -> Context
f pat :: Pattern a
pat = ([Event a] -> [Event a]) -> Pattern a -> Pattern a
forall a b. ([Event a] -> [Event b]) -> Pattern a -> Pattern b
withEvents ((Event a -> Event a) -> [Event a] -> [Event a]
forall a b. (a -> b) -> [a] -> [b]
map (\e :: Event a
e -> Event a
e {context :: Context
context = Context -> Context
f (Context -> Context) -> Context -> Context
forall a b. (a -> b) -> a -> b
$ Event a -> Context
forall a b. EventF a b -> Context
context Event a
e})) Pattern a
pat

deltaContext :: Int -> Int -> Pattern a -> Pattern a
deltaContext :: Int -> Int -> Pattern a -> Pattern a
deltaContext column :: Int
column line :: Int
line pat :: Pattern a
pat = ([Event a] -> [Event a]) -> Pattern a -> Pattern a
forall a b. ([Event a] -> [Event b]) -> Pattern a -> Pattern b
withEvents ((Event a -> Event a) -> [Event a] -> [Event a]
forall a b. (a -> b) -> [a] -> [b]
map (\e :: Event a
e -> Event a
e {context :: Context
context = Context -> Context
f (Context -> Context) -> Context -> Context
forall a b. (a -> b) -> a -> b
$ Event a -> Context
forall a b. EventF a b -> Context
context Event a
e})) Pattern a
pat
  where f :: Context -> Context
        f :: Context -> Context
f (Context xs :: [((Int, Int), (Int, Int))]
xs) = [((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)) -> ((Int, Int), (Int, Int)))
-> [((Int, Int), (Int, Int))] -> [((Int, Int), (Int, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (\((bx :: Int
bx,by :: Int
by), (ex :: Int
ex,ey :: Int
ey)) -> ((Int
bxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
column,Int
byInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
line), (Int
exInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
column,Int
eyInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
line))) [((Int, Int), (Int, Int))]
xs

-- | An event is a value that's active during a timespan. If a whole
-- is present, the part should be equal to or fit inside it.
data EventF a b = Event
  { EventF a b -> Context
context :: Context
  , EventF a b -> Maybe a
whole :: Maybe a
  , EventF a b -> a
part :: a
  , EventF a b -> b
value :: b
  } deriving (EventF a b -> EventF a b -> Bool
(EventF a b -> EventF a b -> Bool)
-> (EventF a b -> EventF a b -> Bool) -> Eq (EventF a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => EventF a b -> EventF a b -> Bool
/= :: EventF a b -> EventF a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => EventF a b -> EventF a b -> Bool
== :: EventF a b -> EventF a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => EventF a b -> EventF a b -> Bool
Eq, Eq (EventF a b)
Eq (EventF a b) =>
(EventF a b -> EventF a b -> Ordering)
-> (EventF a b -> EventF a b -> Bool)
-> (EventF a b -> EventF a b -> Bool)
-> (EventF a b -> EventF a b -> Bool)
-> (EventF a b -> EventF a b -> Bool)
-> (EventF a b -> EventF a b -> EventF a b)
-> (EventF a b -> EventF a b -> EventF a b)
-> Ord (EventF a b)
EventF a b -> EventF a b -> Bool
EventF a b -> EventF a b -> Ordering
EventF a b -> EventF a b -> EventF a b
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
forall a b. (Ord a, Ord b) => Eq (EventF a b)
forall a b. (Ord a, Ord b) => EventF a b -> EventF a b -> Bool
forall a b. (Ord a, Ord b) => EventF a b -> EventF a b -> Ordering
forall a b.
(Ord a, Ord b) =>
EventF a b -> EventF a b -> EventF a b
min :: EventF a b -> EventF a b -> EventF a b
$cmin :: forall a b.
(Ord a, Ord b) =>
EventF a b -> EventF a b -> EventF a b
max :: EventF a b -> EventF a b -> EventF a b
$cmax :: forall a b.
(Ord a, Ord b) =>
EventF a b -> EventF a b -> EventF a b
>= :: EventF a b -> EventF a b -> Bool
$c>= :: forall a b. (Ord a, Ord b) => EventF a b -> EventF a b -> Bool
> :: EventF a b -> EventF a b -> Bool
$c> :: forall a b. (Ord a, Ord b) => EventF a b -> EventF a b -> Bool
<= :: EventF a b -> EventF a b -> Bool
$c<= :: forall a b. (Ord a, Ord b) => EventF a b -> EventF a b -> Bool
< :: EventF a b -> EventF a b -> Bool
$c< :: forall a b. (Ord a, Ord b) => EventF a b -> EventF a b -> Bool
compare :: EventF a b -> EventF a b -> Ordering
$ccompare :: forall a b. (Ord a, Ord b) => EventF a b -> EventF a b -> Ordering
$cp1Ord :: forall a b. (Ord a, Ord b) => Eq (EventF a b)
Ord, a -> EventF a b -> EventF a a
(a -> b) -> EventF a a -> EventF a b
(forall a b. (a -> b) -> EventF a a -> EventF a b)
-> (forall a b. a -> EventF a b -> EventF a a)
-> Functor (EventF a)
forall a b. a -> EventF a b -> EventF a a
forall a b. (a -> b) -> EventF a a -> EventF a b
forall a a b. a -> EventF a b -> EventF a a
forall a a b. (a -> b) -> EventF a a -> EventF a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EventF a b -> EventF a a
$c<$ :: forall a a b. a -> EventF a b -> EventF a a
fmap :: (a -> b) -> EventF a a -> EventF a b
$cfmap :: forall a a b. (a -> b) -> EventF a a -> EventF a b
Functor, (forall x. EventF a b -> Rep (EventF a b) x)
-> (forall x. Rep (EventF a b) x -> EventF a b)
-> Generic (EventF a b)
forall x. Rep (EventF a b) x -> EventF a b
forall x. EventF a b -> Rep (EventF a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (EventF a b) x -> EventF a b
forall a b x. EventF a b -> Rep (EventF a b) x
$cto :: forall a b x. Rep (EventF a b) x -> EventF a b
$cfrom :: forall a b x. EventF a b -> Rep (EventF a b) x
Generic)

type Event a = EventF (ArcF Time) a

instance (NFData a, NFData b) => NFData (EventF a b)

{-instance Bifunctor EventF where
  bimap f g (Event w p e) = Event (f w) (f p) (g e)
-}


isAnalog :: Event a -> Bool
isAnalog :: Event a -> Bool
isAnalog (Event {whole :: forall a b. EventF a b -> Maybe a
whole = Maybe Arc
Nothing}) = Bool
True
isAnalog _ = Bool
False

isDigital :: Event a -> Bool
isDigital :: Event a -> Bool
isDigital = Bool -> Bool
not (Bool -> Bool) -> (Event a -> Bool) -> Event a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Bool
forall a. Event a -> Bool
isAnalog

-- | `True` if an `Event`'s starts is within given `Arc`
onsetIn :: Arc -> Event a -> Bool
onsetIn :: Arc -> Event a -> Bool
onsetIn a :: Arc
a e :: Event a
e = Arc -> Time -> Bool
isIn Arc
a (Event a -> Time
forall a. Event a -> Time
wholeStart Event a
e)

-- | Compares two lists of events, attempting to combine fragmented events in the process
-- for a 'truer' compare
compareDefrag :: (Ord a) => [Event a] -> [Event a] -> Bool
compareDefrag :: [Event a] -> [Event a] -> Bool
compareDefrag as :: [Event a]
as bs :: [Event a]
bs = [Event a] -> [Event a]
forall a. Ord a => [a] -> [a]
sort ([Event a] -> [Event a]
forall a. Eq a => [Event a] -> [Event a]
defragParts [Event a]
as) [Event a] -> [Event a] -> Bool
forall a. Eq a => a -> a -> Bool
== [Event a] -> [Event a]
forall a. Ord a => [a] -> [a]
sort ([Event a] -> [Event a]
forall a. Eq a => [Event a] -> [Event a]
defragParts [Event a]
bs)

-- | Returns a list of events, with any adjacent parts of the same whole combined
defragParts :: Eq a => [Event a] -> [Event a]
defragParts :: [Event a] -> [Event a]
defragParts [] = []
defragParts [e :: Event a
e] = [Event a
e]
defragParts (e :: Event a
e:es :: [Event a]
es) | Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
i = Event a
defraged Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a]
forall a. Eq a => [Event a] -> [Event a]
defragParts (Event a -> [Event a] -> [Event a]
forall a. Eq a => a -> [a] -> [a]
delete Event a
e' [Event a]
es)
                   | Bool
otherwise = Event a
e Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a]
forall a. Eq a => [Event a] -> [Event a]
defragParts [Event a]
es
  where i :: Maybe Int
i = (Event a -> Bool) -> [Event a] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (Event a -> Event a -> Bool
forall a. Eq a => Event a -> Event a -> Bool
isAdjacent Event a
e) [Event a]
es
        e' :: Event a
e' = [Event a]
es [Event a] -> Int -> Event a
forall a. [a] -> Int -> a
!! Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
i
        defraged :: Event a
defraged = Context -> Maybe Arc -> Arc -> a -> Event a
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event (Event a -> Context
forall a b. EventF a b -> Context
context Event a
e) (Event a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole Event a
e) Arc
u (Event a -> a
forall a b. EventF a b -> b
value Event a
e)
        u :: Arc
u = Arc -> Arc -> Arc
hull (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e) (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e')

-- | Returns 'True' if the two given events are adjacent parts of the same whole
isAdjacent :: Eq a => Event a -> Event a -> Bool
isAdjacent :: Event a -> Event a -> Bool
isAdjacent e :: Event a
e e' :: Event a
e' = (Event a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole Event a
e Maybe Arc -> Maybe Arc -> Bool
forall a. Eq a => a -> a -> Bool
== Event a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole Event a
e')
                  Bool -> Bool -> Bool
&& (Event a -> a
forall a b. EventF a b -> b
value Event a
e a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Event a -> a
forall a b. EventF a b -> b
value Event a
e')
                  Bool -> Bool -> Bool
&& ((Arc -> Time
forall a. ArcF a -> a
stop (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e) Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Arc -> Time
forall a. ArcF a -> a
start (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e'))
                      Bool -> Bool -> Bool
||
                      (Arc -> Time
forall a. ArcF a -> a
stop (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e') Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Arc -> Time
forall a. ArcF a -> a
start (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e))
                     )

wholeOrPart :: Event a -> Arc
wholeOrPart :: Event a -> Arc
wholeOrPart (Event {whole :: forall a b. EventF a b -> Maybe a
whole = Just a :: Arc
a}) = Arc
a
wholeOrPart e :: Event a
e = Event a -> Arc
forall a b. EventF a b -> a
part Event a
e

-- | Get the onset of an event's 'whole'
wholeStart :: Event a -> Time
wholeStart :: Event a -> Time
wholeStart = Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> (Event a -> Arc) -> Event a -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Arc
forall a. Event a -> Arc
wholeOrPart

-- | Get the offset of an event's 'whole'
wholeStop :: Event a -> Time
wholeStop :: Event a -> Time
wholeStop = Arc -> Time
forall a. ArcF a -> a
stop (Arc -> Time) -> (Event a -> Arc) -> Event a -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Arc
forall a. Event a -> Arc
wholeOrPart

-- | Get the onset of an event's 'whole'
eventPartStart :: Event a -> Time
eventPartStart :: Event a -> Time
eventPartStart = Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> (Event a -> Arc) -> Event a -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Arc
forall a b. EventF a b -> a
part

-- | Get the offset of an event's 'part'
eventPartStop :: Event a -> Time
eventPartStop :: Event a -> Time
eventPartStop = Arc -> Time
forall a. ArcF a -> a
stop (Arc -> Time) -> (Event a -> Arc) -> Event a -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Arc
forall a b. EventF a b -> a
part

-- | Get the timespan of an event's 'part'
eventPart :: Event a -> Arc
eventPart :: Event a -> Arc
eventPart = Event a -> Arc
forall a b. EventF a b -> a
part

eventValue :: Event a -> a
eventValue :: Event a -> a
eventValue = Event a -> a
forall a b. EventF a b -> b
value

eventHasOnset :: Event a -> Bool
eventHasOnset :: Event a -> Bool
eventHasOnset e :: Event a
e | Event a -> Bool
forall a. Event a -> Bool
isAnalog Event a
e = Bool
False
                | Bool
otherwise = Arc -> Time
forall a. ArcF a -> a
start (Maybe Arc -> Arc
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Arc -> Arc) -> Maybe Arc -> Arc
forall a b. (a -> b) -> a -> b
$ Event a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole Event a
e) Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Arc -> Time
forall a. ArcF a -> a
start (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e)

-- TODO - Is this used anywhere? Just tests, it seems
-- TODO - support 'context' field
toEvent :: (((Time, Time), (Time, Time)), a) -> Event a
toEvent :: (((Time, Time), (Time, Time)), a) -> Event a
toEvent (((ws :: Time
ws, we :: Time
we), (ps :: Time
ps, pe :: Time
pe)), v :: a
v) = 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 -> Maybe Arc) -> Arc -> Maybe Arc
forall a b. (a -> b) -> a -> b
$ Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
ws Time
we) (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
ps Time
pe) a
v

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

-- | A function that represents events taking place over time
type Query a = (State -> [Event a])

-- | A datatype that's basically a query
data Pattern a = Pattern {Pattern a -> Query a
query :: Query 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

data Value = VS { Value -> String
svalue :: String }
           | VF { Value -> Double
fvalue :: Double }
           | VR { Value -> Time
rvalue :: Rational }
           | VI { Value -> Int
ivalue :: Int }
           | VB { Value -> Bool
bvalue :: Bool }
           | VX { Value -> [Word8]
xvalue :: [Word8] } -- Used for OSC 'blobs'
           deriving (Typeable,Typeable Value
Constr
DataType
Typeable Value =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Value -> c Value)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Value)
-> (Value -> Constr)
-> (Value -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Value))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Value))
-> ((forall b. Data b => b -> b) -> Value -> Value)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Value -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Value -> r)
-> (forall u. (forall d. Data d => d -> u) -> Value -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Value -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Value -> m Value)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Value -> m Value)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Value -> m Value)
-> Data Value
Value -> Constr
Value -> DataType
(forall b. Data b => b -> b) -> Value -> Value
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Value -> c Value
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Value
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Value -> u
forall u. (forall d. Data d => d -> u) -> Value -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Value -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Value -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Value -> m Value
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Value -> m Value
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Value
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Value -> c Value
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Value)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Value)
$cVX :: Constr
$cVB :: Constr
$cVI :: Constr
$cVR :: Constr
$cVF :: Constr
$cVS :: Constr
$tValue :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Value -> m Value
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Value -> m Value
gmapMp :: (forall d. Data d => d -> m d) -> Value -> m Value
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Value -> m Value
gmapM :: (forall d. Data d => d -> m d) -> Value -> m Value
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Value -> m Value
gmapQi :: Int -> (forall d. Data d => d -> u) -> Value -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Value -> u
gmapQ :: (forall d. Data d => d -> u) -> Value -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Value -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Value -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Value -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Value -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Value -> r
gmapT :: (forall b. Data b => b -> b) -> Value -> Value
$cgmapT :: (forall b. Data b => b -> b) -> Value -> Value
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Value)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Value)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Value)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Value)
dataTypeOf :: Value -> DataType
$cdataTypeOf :: Value -> DataType
toConstr :: Value -> Constr
$ctoConstr :: Value -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Value
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Value
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Value -> c Value
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Value -> c Value
$cp1Data :: Typeable Value
Data, (forall x. Value -> Rep Value x)
-> (forall x. Rep Value x -> Value) -> Generic Value
forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Value x -> Value
$cfrom :: forall x. Value -> Rep Value x
Generic)

class Valuable a where
  toValue :: a -> Value

instance NFData Value

instance Valuable String where
  toValue :: String -> Value
toValue = String -> Value
VS
instance Valuable Double where
  toValue :: Double -> Value
toValue a :: Double
a = Double -> Value
VF Double
a
instance Valuable Rational where
  toValue :: Time -> Value
toValue a :: Time
a = Time -> Value
VR Time
a
instance Valuable Int where
  toValue :: Int -> Value
toValue a :: Int
a = Int -> Value
VI Int
a
instance Valuable Bool where
  toValue :: Bool -> Value
toValue a :: Bool
a = Bool -> Value
VB Bool
a
instance Valuable [Word8] where
  toValue :: [Word8] -> Value
toValue a :: [Word8]
a = [Word8] -> Value
VX [Word8]
a

instance Eq Value where
  (VS x :: String
x) == :: Value -> Value -> Bool
== (VS y :: String
y) = String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y
  (VB x :: Bool
x) == (VB y :: Bool
y) = Bool
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
y
  (VF x :: Double
x) == (VF y :: Double
y) = Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
y
  (VI x :: Int
x) == (VI y :: Int
y) = Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y
  (VR x :: Time
x) == (VR y :: Time
y) = Time
x Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
y
  (VX x :: [Word8]
x) == (VX y :: [Word8]
y) = [Word8]
x [Word8] -> [Word8] -> Bool
forall a. Eq a => a -> a -> Bool
== [Word8]
y
  
  (VF x :: Double
x) == (VI y :: Int
y) = Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
  (VI y :: Int
y) == (VF x :: Double
x) = Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)

  (VF x :: Double
x) == (VR y :: Time
y) = (Double -> Time
forall a. Real a => a -> Time
toRational Double
x) Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
y
  (VR y :: Time
y) == (VF x :: Double
x) = (Double -> Time
forall a. Real a => a -> Time
toRational Double
x) Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
y
  (VI x :: Int
x) == (VR y :: Time
y) = (Int -> Time
forall a. Real a => a -> Time
toRational Int
x) Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
y
  (VR y :: Time
y) == (VI x :: Int
x) = (Int -> Time
forall a. Real a => a -> Time
toRational Int
x) Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
y

  _ == _ = Bool
False
  
instance Ord Value where
  compare :: Value -> Value -> Ordering
compare (VS x :: String
x) (VS y :: String
y) = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
x String
y
  compare (VB x :: Bool
x) (VB y :: Bool
y) = Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bool
x Bool
y
  compare (VF x :: Double
x) (VF y :: Double
y) = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
x Double
y
  compare (VI x :: Int
x) (VI y :: Int
y) = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
x Int
y
  compare (VR x :: Time
x) (VR y :: Time
y) = Time -> Time -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Time
x Time
y
  compare (VX x :: [Word8]
x) (VX y :: [Word8]
y) = [Word8] -> [Word8] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Word8]
x [Word8]
y
  compare (VS _) _ = Ordering
LT
  compare _ (VS _) = Ordering
GT
  compare (VB _) _ = Ordering
LT
  compare _ (VB _) = Ordering
GT
  compare (VX _) _ = Ordering
LT
  compare _ (VX _) = Ordering
GT
  compare (VF x :: Double
x) (VI y :: Int
y) = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
x (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
  compare (VI x :: Int
x) (VF y :: Double
y) = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) Double
y

  compare (VR x :: Time
x) (VI y :: Int
y) = Time -> Time -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Time
x (Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
  compare (VI x :: Int
x) (VR y :: Time
y) = Time -> Time -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) Time
y

  compare (VF x :: Double
x) (VR y :: Time
y) = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
x (Time -> Double
forall a. Fractional a => Time -> a
fromRational Time
y)
  compare (VR x :: Time
x) (VF y :: Double
y) = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Time -> Double
forall a. Fractional a => Time -> a
fromRational Time
x) Double
y

type StateMap = Map.Map String (Pattern Value)
type ControlMap = Map.Map String Value
type ControlPattern = Pattern ControlMap

------------------------------------------------------------------------
-- * Instances

instance NFData a => NFData (Pattern a)

instance Functor Pattern where
  -- | apply a function to all the values in a pattern
  fmap :: (a -> b) -> Pattern a -> Pattern b
fmap f :: a -> b
f p :: Pattern a
p = Pattern a
p {query :: Query b
query = (EventF Arc a -> EventF Arc b) -> [EventF Arc a] -> [EventF Arc b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> EventF Arc a -> EventF Arc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) ([EventF Arc a] -> [EventF Arc b])
-> (State -> [EventF Arc a]) -> Query b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> State -> [EventF Arc a]
forall a. Pattern a -> Query a
query Pattern a
p}

applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc))
-> Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPat combineWholes :: Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)
combineWholes pf :: Pattern (a -> b)
pf px :: Pattern a
px = Query b -> Pattern b
forall a. Query a -> Pattern a
Pattern Query b
q
    where q :: Query b
q st :: State
st = [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (EventF Arc b)] -> [EventF Arc b])
-> [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> b) -> a -> b
$ (EventF Arc (a -> b) -> [Maybe (EventF Arc b)])
-> [EventF Arc (a -> b)] -> [Maybe (EventF Arc b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
forall b. EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match ([EventF Arc (a -> b)] -> [Maybe (EventF Arc b)])
-> [EventF Arc (a -> b)] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> a -> b
$ Pattern (a -> b) -> Query (a -> b)
forall a. Pattern a -> Query 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 c :: [((Int, Int), (Int, Int))]
c) _ fPart :: Arc
fPart f :: 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 c' :: [((Int, Int), (Int, Int))]
c') _ xPart :: Arc
xPart x :: 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 -> Query a
forall a. Pattern a -> Query a
query Pattern a
px Query a -> Query 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)})

instance Applicative Pattern where
  -- | Repeat the given value once per cycle, forever
  pure :: a -> Pattern a
pure v :: a
v = Query a -> Pattern a
forall a. Query a -> Pattern a
Pattern (Query a -> Pattern a) -> Query a -> Pattern a
forall a b. (a -> b) -> a -> b
$ \(State a :: Arc
a _) ->
    (Arc -> EventF Arc a) -> [Arc] -> [EventF Arc a]
forall a b. (a -> b) -> [a] -> [b]
map (\a' :: Arc
a' -> Context -> Maybe Arc -> Arc -> a -> EventF Arc 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] -> [EventF Arc a]) -> [Arc] -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ Arc -> [Arc]
cycleArcsInArc Arc
a

  <*> :: 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

applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatBoth pf :: Pattern (a -> b)
pf px :: Pattern a
px = Query b -> Pattern b
forall a. Query a -> Pattern a
Pattern Query b
q
    where q :: Query b
q st :: State
st = [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (EventF Arc b)] -> [EventF Arc b])
-> [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> b) -> a -> b
$ ((EventF Arc (a -> b) -> [Maybe (EventF Arc b)])
-> [EventF Arc (a -> b)] -> [Maybe (EventF Arc b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
forall b. EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match ([EventF Arc (a -> b)] -> [Maybe (EventF Arc b)])
-> [EventF Arc (a -> b)] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> a -> b
$ Pattern (a -> b) -> Query (a -> b)
forall a. Pattern a -> Query a
query Pattern (a -> b)
pf State
st) [Maybe (EventF Arc b)]
-> [Maybe (EventF Arc b)] -> [Maybe (EventF Arc b)]
forall a. [a] -> [a] -> [a]
++ ((EventF Arc a -> [Maybe (EventF Arc b)])
-> [EventF Arc a] -> [Maybe (EventF Arc b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc a -> [Maybe (EventF Arc b)]
matchX ([EventF Arc a] -> [Maybe (EventF Arc b)])
-> [EventF Arc a] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Query a
forall a. Pattern a -> Query 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 _ Nothing fPart :: Arc
fPart _)   = (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 -> Query a
forall a. Pattern a -> Query a
query Pattern a
px Query a -> Query 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 _ (Just fWhole :: Arc
fWhole) _ _) = (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 -> Query a
forall a. Pattern a -> Query a
query (Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
filterDigital Pattern a
px) Query a -> Query 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 (EventF Arc b)]
matchX ex :: EventF Arc a
ex@(Event _ Nothing fPart :: Arc
fPart _)  = (EventF Arc (a -> b) -> Maybe (EventF Arc b))
-> [EventF Arc (a -> b)] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> [a] -> [b]
map (\ef :: EventF Arc (a -> b)
ef -> 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 EventF Arc a
ex) (Pattern (a -> b) -> Query (a -> b)
forall a. Pattern a -> Query a
query (Pattern (a -> b) -> Pattern (a -> b)
forall a. Pattern a -> Pattern a
filterDigital Pattern (a -> b)
pf) Query (a -> b) -> Query (a -> b)
forall a b. (a -> b) -> a -> b
$ State
st {arc :: Arc
arc = Arc
fPart}) -- digital
              matchX _ = String -> [Maybe (EventF Arc b)]
forall a. HasCallStack => String -> a
error "can't happen"
              withFX :: EventF Arc (t -> b) -> EventF Arc t -> Maybe (EventF Arc b)
withFX ef :: EventF Arc (t -> b)
ef ex :: 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 :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatLeft pf :: Pattern (a -> b)
pf px :: Pattern a
px = Query b -> Pattern b
forall a. Query a -> Pattern a
Pattern Query b
q
    where q :: Query b
q st :: State
st = [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (EventF Arc b)] -> [EventF Arc b])
-> [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> b) -> a -> b
$ ((EventF Arc (a -> b) -> [Maybe (EventF Arc b)])
-> [EventF Arc (a -> b)] -> [Maybe (EventF Arc b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
forall b. EventF Arc (a -> b) -> [Maybe (EventF Arc b)]
match ([EventF Arc (a -> b)] -> [Maybe (EventF Arc b)])
-> [EventF Arc (a -> b)] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> a -> b
$ Pattern (a -> b) -> Query (a -> b)
forall a. Pattern a -> Query 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 = (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 -> Query a
forall a. Pattern a -> Query a
query Pattern a
px Query a -> Query 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 ef :: EventF Arc (t -> b)
ef ex :: 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 :: Pattern (a -> b) -> Pattern a -> Pattern b
applyPatToPatRight pf :: Pattern (a -> b)
pf px :: Pattern a
px = Query b -> Pattern b
forall a. Query a -> Pattern a
Pattern Query b
q
    where q :: Query b
q st :: State
st = [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (EventF Arc b)] -> [EventF Arc b])
-> [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> b) -> a -> b
$ ((EventF Arc a -> [Maybe (EventF Arc b)])
-> [EventF Arc a] -> [Maybe (EventF Arc b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EventF Arc a -> [Maybe (EventF Arc b)]
match ([EventF Arc a] -> [Maybe (EventF Arc b)])
-> [EventF Arc a] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
px State
st)
            where
              match :: EventF Arc a -> [Maybe (EventF Arc b)]
match ex :: EventF Arc a
ex = (EventF Arc (a -> b) -> Maybe (EventF Arc b))
-> [EventF Arc (a -> b)] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> [a] -> [b]
map (\ef :: EventF Arc (a -> b)
ef -> 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 EventF Arc a
ex) (Pattern (a -> b) -> Query (a -> b)
forall a. Pattern a -> Query a
query Pattern (a -> b)
pf Query (a -> b) -> Query (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 (b -> b) -> EventF Arc b -> Maybe (EventF Arc b)
withFX ef :: EventF Arc (b -> b)
ef ex :: EventF Arc b
ex = do let whole' :: Maybe Arc
whole' = EventF Arc b -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc b
ex
                                Arc
part' <- Arc -> Arc -> Maybe Arc
subArc (EventF Arc (b -> b) -> Arc
forall a b. EventF a b -> a
part EventF Arc (b -> b)
ef) (EventF Arc b -> Arc
forall a b. EventF a b -> a
part EventF Arc b
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 (b -> b) -> Context
forall a b. EventF a b -> Context
context EventF Arc (b -> b)
ef, EventF Arc b -> Context
forall a b. EventF a b -> Context
context EventF Arc b
ex]) Maybe Arc
whole' Arc
part' (EventF Arc (b -> b) -> b -> b
forall a b. EventF a b -> b
value EventF Arc (b -> b)
ef (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ EventF Arc b -> b
forall a b. EventF a b -> b
value EventF Arc b
ex))


-- | Like <*>, but the 'wholes' come from the left
(<*) :: Pattern (a -> b) -> Pattern a -> Pattern 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
*> :: 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 <*, *>

instance Monad Pattern where
  return :: a -> Pattern a
return = a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  p :: Pattern a
p >>= :: Pattern a -> (a -> Pattern b) -> Pattern b
>>= f :: 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 :: Pattern (Pattern a) -> Pattern a
unwrap pp :: Pattern (Pattern a)
pp = Pattern (Pattern a)
pp {query :: Query a
query = Query a
q}
  where q :: Query a
q st :: State
st = (EventF Arc (Pattern a) -> [EventF Arc a])
-> [EventF Arc (Pattern a)] -> [EventF Arc a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
          (\(Event c :: Context
c w :: Maybe Arc
w p :: Arc
p v :: Pattern a
v) ->
             (EventF Arc a -> Maybe (EventF Arc a))
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> Maybe Arc -> Arc -> EventF Arc a -> Maybe (EventF Arc a)
forall b.
Context -> Maybe Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
c Maybe Arc
w Arc
p) ([EventF Arc a] -> [EventF Arc a])
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
v State
st {arc :: Arc
arc = Arc
p})
          (Pattern (Pattern a) -> Query (Pattern a)
forall a. Pattern a -> Query a
query Pattern (Pattern a)
pp State
st)
        munge :: Context -> Maybe Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge oc :: Context
oc ow :: Maybe Arc
ow op :: Arc
op (Event ic :: Context
ic iw :: Maybe Arc
iw ip :: Arc
ip v' :: 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 :: Pattern (Pattern a) -> Pattern a
innerJoin pp :: Pattern (Pattern a)
pp = Pattern (Pattern a)
pp {query :: Query a
query = Query a
q}
  where q :: Query a
q st :: State
st = (EventF Arc (Pattern a) -> [EventF Arc a])
-> [EventF Arc (Pattern a)] -> [EventF Arc a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
               (\(Event oc :: Context
oc _ op :: Arc
op v :: Pattern a
v) -> (EventF Arc a -> Maybe (EventF Arc a))
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> EventF Arc a -> Maybe (EventF Arc a)
forall b. Context -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
oc) ([EventF Arc a] -> [EventF Arc a])
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
v State
st {arc :: Arc
arc = Arc
op}
          )
          (Pattern (Pattern a) -> Query (Pattern a)
forall a. Pattern a -> Query a
query Pattern (Pattern a)
pp State
st)
          where munge :: Context -> EventF Arc b -> Maybe (EventF Arc b)
munge oc :: Context
oc (Event ic :: Context
ic iw :: Maybe Arc
iw ip :: Arc
ip v :: 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 :: Pattern (Pattern a) -> Pattern a
outerJoin pp :: Pattern (Pattern a)
pp = Pattern (Pattern a)
pp {query :: Query a
query = Query a
q}
  where q :: Query a
q st :: State
st = (EventF Arc (Pattern a) -> [EventF Arc a])
-> [EventF Arc (Pattern a)] -> [EventF Arc a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
          (\e :: EventF Arc (Pattern a)
e ->
             (EventF Arc a -> Maybe (EventF Arc a))
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> Maybe Arc -> Arc -> EventF Arc a -> Maybe (EventF Arc 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)) ([EventF Arc a] -> [EventF Arc a])
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Query a
forall a. Pattern a -> Query 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 = Time -> Arc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> Arc -> Time
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) -> Query (Pattern a)
forall a. Pattern a -> Query a
query Pattern (Pattern a)
pp State
st)
          where munge :: Context -> Maybe Arc -> Arc -> EventF a b -> Maybe (EventF Arc b)
munge oc :: Context
oc ow :: Maybe Arc
ow op :: Arc
op (Event ic :: Context
ic _ _ v' :: 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 :: Pattern (Pattern a) -> Pattern a
squeezeJoin pp :: Pattern (Pattern a)
pp = Pattern (Pattern a)
pp {query :: Query a
query = Query a
q}
  where q :: Query a
q st :: State
st = (EventF Arc (Pattern a) -> [EventF Arc a])
-> [EventF Arc (Pattern a)] -> [EventF Arc a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
          (\e :: EventF Arc (Pattern a)
e@(Event c :: Context
c w :: Maybe Arc
w p :: Arc
p v :: Pattern a
v) ->
             (EventF Arc a -> Maybe (EventF Arc a))
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> Maybe Arc -> Arc -> EventF Arc a -> Maybe (EventF Arc a)
forall b.
Context -> Maybe Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
c Maybe Arc
w Arc
p) ([EventF Arc a] -> [EventF Arc a])
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Query a
forall a. Pattern a -> Query 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) -> Query (Pattern a)
forall a. Pattern a -> Query a
query Pattern (Pattern a)
pp State
st)
        munge :: Context -> Maybe Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge oContext :: Context
oContext oWhole :: Maybe Arc
oWhole oPart :: Arc
oPart (Event iContext :: Context
iContext iWhole :: Maybe Arc
iWhole iPart :: Arc
iPart v :: 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)

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

class TolerantEq a where
   (~==) :: a -> a -> Bool

instance TolerantEq Value where
         (VS a :: String
a) ~== :: Value -> Value -> Bool
~== (VS b :: String
b) = String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b
         (VI a :: Int
a) ~== (VI b :: Int
b) = Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b
         (VR a :: Time
a) ~== (VR b :: Time
b) = Time
a Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
b
         (VF a :: Double
a) ~== (VF b :: Double
b) = Double -> Double
forall a. Num a => a -> a
abs (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< 0.000001
         _ ~== _ = Bool
False

instance TolerantEq ControlMap where
  a :: ControlMap
a ~== :: ControlMap -> ControlMap -> Bool
~== b :: ControlMap
b = (Value -> Value -> Maybe Value)
-> ControlMap -> ControlMap -> ControlMap
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith (\a' :: Value
a' b' :: Value
b' -> if Value
a' Value -> Value -> Bool
forall a. TolerantEq a => a -> a -> Bool
~== Value
b' then Maybe Value
forall a. Maybe a
Nothing else Value -> Maybe Value
forall a. a -> Maybe a
Just Value
a') ControlMap
a ControlMap
b ControlMap -> ControlMap -> Bool
forall a. Eq a => a -> a -> Bool
== ControlMap
forall k a. Map k a
Map.empty

instance TolerantEq (Event ControlMap) where
  (Event _ w :: Maybe Arc
w p :: Arc
p x :: ControlMap
x) ~== :: Event ControlMap -> Event ControlMap -> Bool
~== (Event _ w' :: Maybe Arc
w' p' :: Arc
p' x' :: ControlMap
x') = Maybe Arc
w Maybe Arc -> Maybe Arc -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Arc
w' Bool -> Bool -> Bool
&& Arc
p Arc -> Arc -> Bool
forall a. Eq a => a -> a -> Bool
== Arc
p' Bool -> Bool -> Bool
&& ControlMap
x ControlMap -> ControlMap -> Bool
forall a. TolerantEq a => a -> a -> Bool
~== ControlMap
x'

instance TolerantEq a => TolerantEq [a] where
  as :: [a]
as ~== :: [a] -> [a] -> Bool
~== bs :: [a]
bs = ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bs) Bool -> Bool -> Bool
&& ((a, a) -> Bool) -> [(a, a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((a -> a -> Bool) -> (a, a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> Bool
forall a. TolerantEq a => a -> a -> Bool
(~==)) ([a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as [a]
bs)


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

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 "compare"
  <= :: Pattern a -> Pattern a -> Bool
(<=) = String -> Pattern a -> Pattern a -> Bool
forall a. String -> a
noOv "(<=)"

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 "fromEnum"
  enumFrom :: Pattern a -> [Pattern a]
enumFrom       = String -> Pattern a -> [Pattern a]
forall a. String -> a
noOv "enumFrom"
  enumFromThen :: Pattern a -> Pattern a -> [Pattern a]
enumFromThen   = String -> Pattern a -> Pattern a -> [Pattern a]
forall a. String -> a
noOv "enumFromThen"
  enumFromTo :: Pattern a -> Pattern a -> [Pattern a]
enumFromTo     = String -> Pattern a -> Pattern a -> [Pattern a]
forall a. String -> a
noOv "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 "enumFromThenTo"

instance (Num a, Ord a) => Real (Pattern a) where
  toRational :: Pattern a -> Time
toRational = String -> Pattern a -> Time
forall a. String -> a
noOv "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 "toInteger"
  x :: Pattern a
x quotRem :: Pattern a -> Pattern a -> (Pattern a, Pattern a)
`quotRem` y :: 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)
  x :: Pattern a
x divMod :: Pattern a -> Pattern a -> (Pattern a, Pattern a)
`divMod`  y :: 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 :: Time -> Pattern a
fromRational = a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Pattern a) -> (Time -> a) -> Time -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> a
forall a. Fractional a => Time -> 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 :: Pattern a -> (b, Pattern a)
properFraction = String -> Pattern a -> (b, Pattern a)
forall a. String -> a
noOv "properFraction"
  truncate :: Pattern a -> b
truncate       = String -> Pattern a -> b
forall a. String -> a
noOv "truncate"
  round :: Pattern a -> b
round          = String -> Pattern a -> b
forall a. String -> a
noOv "round"
  ceiling :: Pattern a -> b
ceiling        = String -> Pattern a -> b
forall a. String -> a
noOv "ceiling"
  floor :: Pattern a -> b
floor          = String -> Pattern a -> b
forall a. String -> a
noOv "floor"

instance (RealFloat a) => RealFloat (Pattern a) where
  floatRadix :: Pattern a -> Integer
floatRadix     = String -> Pattern a -> Integer
forall a. String -> a
noOv "floatRadix"
  floatDigits :: Pattern a -> Int
floatDigits    = String -> Pattern a -> Int
forall a. String -> a
noOv "floatDigits"
  floatRange :: Pattern a -> (Int, Int)
floatRange     = String -> Pattern a -> (Int, Int)
forall a. String -> a
noOv "floatRange"
  decodeFloat :: Pattern a -> (Integer, Int)
decodeFloat    = String -> Pattern a -> (Integer, Int)
forall a. String -> a
noOv "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 "exponent"
  significand :: Pattern a -> Pattern a
significand    = String -> Pattern a -> Pattern a
forall a. String -> a
noOv "significand"
  scaleFloat :: Int -> Pattern a -> Pattern a
scaleFloat n :: 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 "isNaN"
  isInfinite :: Pattern a -> Bool
isInfinite     = String -> Pattern a -> Bool
forall a. String -> a
noOv "isInfinite"
  isDenormalized :: Pattern a -> Bool
isDenormalized = String -> Pattern a -> Bool
forall a. String -> a
noOv "isDenormalized"
  isNegativeZero :: Pattern a -> Bool
isNegativeZero = String -> Pattern a -> Bool
forall a. String -> a
noOv "isNegativeZero"
  isIEEE :: Pattern a -> Bool
isIEEE         = String -> Pattern a -> Bool
forall a. String -> a
noOv "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 ControlMap where
  negate :: ControlMap -> ControlMap
negate      = ((Double -> Double) -> (Int -> Int) -> ShowS -> Value -> Value
applyFIS Double -> Double
forall a. Num a => a -> a
negate Int -> Int
forall a. Num a => a -> a
negate ShowS
forall a. a -> a
id (Value -> Value) -> ControlMap -> ControlMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  + :: ControlMap -> ControlMap -> ControlMap
(+)         = (Value -> Value -> Value) -> ControlMap -> ControlMap -> ControlMap
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
(+))
  * :: ControlMap -> ControlMap -> ControlMap
(*)         = (Value -> Value -> Value) -> ControlMap -> ControlMap -> ControlMap
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 -> ControlMap
fromInteger i :: Integer
i = String -> Value -> ControlMap
forall k a. k -> a -> Map k a
Map.singleton "n" (Value -> ControlMap) -> Value -> ControlMap
forall a b. (a -> b) -> a -> b
$ Int -> Value
VI (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i
  signum :: ControlMap -> ControlMap
signum      = ((Double -> Double) -> (Int -> Int) -> ShowS -> Value -> Value
applyFIS Double -> Double
forall a. Num a => a -> a
signum Int -> Int
forall a. Num a => a -> a
signum ShowS
forall a. a -> a
id (Value -> Value) -> ControlMap -> ControlMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  abs :: ControlMap -> ControlMap
abs         = ((Double -> Double) -> (Int -> Int) -> ShowS -> Value -> Value
applyFIS Double -> Double
forall a. Num a => a -> a
abs Int -> Int
forall a. Num a => a -> a
abs ShowS
forall a. a -> a
id (Value -> Value) -> ControlMap -> ControlMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

instance Fractional ControlMap where
  recip :: ControlMap -> ControlMap
recip        = (Value -> Value) -> ControlMap -> ControlMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Double -> Double) -> (Int -> Int) -> ShowS -> Value -> Value
applyFIS Double -> Double
forall a. Fractional a => a -> a
recip Int -> Int
forall a. a -> a
id ShowS
forall a. a -> a
id)
  fromRational :: Time -> ControlMap
fromRational = String -> Value -> ControlMap
forall k a. k -> a -> Map k a
Map.singleton "speed" (Value -> ControlMap) -> (Time -> Value) -> Time -> ControlMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Value
VF (Double -> Value) -> (Time -> Double) -> Time -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> Double
forall a. Fractional a => Time -> a
fromRational

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

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

queryArc :: Pattern a -> Arc -> [Event a]
queryArc :: Pattern a -> Arc -> [Event a]
queryArc p :: Pattern a
p a :: Arc
a = Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
p Query a -> Query a
forall a b. (a -> b) -> a -> b
$ Arc -> StateMap -> State
State Arc
a StateMap
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 :: Pattern a -> Pattern a
splitQueries :: Pattern a -> Pattern a
splitQueries p :: Pattern a
p = Pattern a
p {query :: Query a
query = \st :: State
st -> (Arc -> [Event a]) -> [Arc] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a :: Arc
a -> Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
p State
st {arc :: Arc
arc = Arc
a}) ([Arc] -> [Event a]) -> [Arc] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Arc -> [Arc]
arcCyclesZW (State -> Arc
arc State
st)}

-- | Apply a function to the arcs/timespans (both whole and parts) of the result
withResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a
withResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a
withResultArc f :: Arc -> Arc
f pat :: Pattern a
pat = Pattern a
pat
  { query :: Query a
query = (EventF Arc a -> EventF Arc a) -> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> b) -> [a] -> [b]
map (\(Event c :: Context
c w :: Maybe Arc
w p :: Arc
p e :: a
e) -> Context -> Maybe Arc -> Arc -> a -> EventF Arc a
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event Context
c (Arc -> Arc
f (Arc -> Arc) -> Maybe Arc -> Maybe Arc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Arc
w) (Arc -> Arc
f Arc
p) a
e) ([EventF Arc a] -> [EventF Arc a]) -> Query a -> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
pat}

-- | Apply a function to the time (both start and end of the timespans
-- of both whole and parts) of the result
withResultTime :: (Time -> Time) -> Pattern a -> Pattern a
withResultTime :: (Time -> Time) -> Pattern a -> Pattern a
withResultTime f :: Time -> Time
f = (Arc -> Arc) -> Pattern a -> Pattern a
forall a. (Arc -> Arc) -> Pattern a -> Pattern a
withResultArc (\(Arc s :: Time
s e :: Time
e) -> Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
f Time
s) (Time -> Time
f Time
e))

-- | Apply a function to the timespan of the query
withQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a
withQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a
withQueryArc f :: Arc -> Arc
f p :: Pattern a
p = Pattern a
p {query :: Query a
query = Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
p Query a -> (State -> State) -> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(State a :: Arc
a m :: StateMap
m) -> Arc -> StateMap -> State
State (Arc -> Arc
f Arc
a) StateMap
m)}

-- | Apply a function to the time (both start and end) of the query
withQueryTime :: (Time -> Time) -> Pattern a -> Pattern a
withQueryTime :: (Time -> Time) -> Pattern a -> Pattern a
withQueryTime f :: Time -> Time
f = (Arc -> Arc) -> Pattern a -> Pattern a
forall a. (Arc -> Arc) -> Pattern a -> Pattern a
withQueryArc (\(Arc s :: Time
s e :: Time
e) -> Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
f Time
s) (Time -> Time
f Time
e))

-- | @withEvent f p@ returns a new @Pattern@ with each event mapped over
-- function @f@.
withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b
withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b
withEvent f :: Event a -> Event b
f p :: Pattern a
p = Pattern a
p {query :: Query b
query = (Event a -> Event b) -> [Event a] -> [Event b]
forall a b. (a -> b) -> [a] -> [b]
map Event a -> Event b
f ([Event a] -> [Event b]) -> (State -> [Event a]) -> Query b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> State -> [Event a]
forall a. Pattern a -> Query a
query Pattern a
p}

-- | @withEvent f p@ returns a new @Pattern@ with f applied to the resulting list of events for each query
-- function @f@.
withEvents :: ([Event a] -> [Event b]) -> Pattern a -> Pattern b
withEvents :: ([Event a] -> [Event b]) -> Pattern a -> Pattern b
withEvents f :: [Event a] -> [Event b]
f p :: Pattern a
p = Pattern a
p {query :: Query b
query = [Event a] -> [Event b]
f ([Event a] -> [Event b]) -> (State -> [Event a]) -> Query b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> State -> [Event a]
forall a. Pattern a -> Query a
query Pattern a
p}

-- | @withPart f p@ returns a new @Pattern@ with function @f@ applied
-- to the part.
withPart :: (Arc -> Arc) -> Pattern a -> Pattern a
withPart :: (Arc -> Arc) -> Pattern a -> Pattern a
withPart f :: Arc -> Arc
f = (Event a -> Event a) -> Pattern a -> Pattern a
forall a b. (Event a -> Event b) -> Pattern a -> Pattern b
withEvent (\(Event c :: Context
c w :: Maybe Arc
w p :: Arc
p v :: a
v) -> Context -> Maybe Arc -> Arc -> a -> Event a
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event Context
c Maybe Arc
w (Arc -> Arc
f Arc
p) a
v)

-- | Apply one of three functions to a Value, depending on its type
applyFIS :: (Double -> Double) -> (Int -> Int) -> (String -> String) -> Value -> Value
applyFIS :: (Double -> Double) -> (Int -> Int) -> ShowS -> Value -> Value
applyFIS f :: Double -> Double
f _ _ (VF f' :: Double
f') = Double -> Value
VF (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Double -> Double
f Double
f'
applyFIS _ f :: Int -> Int
f _ (VI i :: Int
i ) = Int -> Value
VI (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Int
f Int
i
applyFIS _ _ f :: ShowS
f (VS s :: String
s ) = String -> Value
VS (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ ShowS
f String
s
applyFIS _ _ _ v :: Value
v = Value
v

-- | Apply one of two functions to a Value, depending on its type (int
-- or float; strings and rationals are ignored)
fNum2 :: (Int -> Int -> Int) -> (Double -> Double -> Double) -> Value -> Value -> Value
fNum2 :: (Int -> Int -> Int)
-> (Double -> Double -> Double) -> Value -> Value -> Value
fNum2 fInt :: Int -> Int -> Int
fInt _      (VI a :: Int
a) (VI b :: Int
b) = Int -> Value
VI (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
fInt Int
a Int
b
fNum2 _    fFloat :: Double -> Double -> Double
fFloat (VF a :: Double
a) (VF b :: Double
b) = Double -> Value
VF (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
fFloat Double
a Double
b
fNum2 _    fFloat :: Double -> Double -> Double
fFloat (VI a :: Int
a) (VF b :: Double
b) = Double -> Value
VF (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
fFloat (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a) Double
b
fNum2 _    fFloat :: Double -> Double -> Double
fFloat (VF a :: Double
a) (VI b :: Int
b) = Double -> Value
VF (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
fFloat Double
a (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b)
fNum2 _    _      x :: Value
x      _      = Value
x

getI :: Value -> Maybe Int
getI :: Value -> Maybe Int
getI (VI i :: Int
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
getI (VR x :: Time
x) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Time -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Time
x
getI (VF x :: Double
x) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
x
getI _  = Maybe Int
forall a. Maybe a
Nothing

getF :: Value -> Maybe Double
getF :: Value -> Maybe Double
getF (VF f :: Double
f) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
f
getF (VR x :: Time
x) = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Time -> Double
forall a. Fractional a => Time -> a
fromRational Time
x
getF (VI x :: Int
x) = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
getF _  = Maybe Double
forall a. Maybe a
Nothing

getS :: Value -> Maybe String
getS :: Value -> Maybe String
getS (VS s :: String
s) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
getS _  = Maybe String
forall a. Maybe a
Nothing

getB :: Value -> Maybe Bool
getB :: Value -> Maybe Bool
getB (VB b :: Bool
b) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
getB _  = Maybe Bool
forall a. Maybe a
Nothing

getR :: Value -> Maybe Rational
getR :: Value -> Maybe Time
getR (VR r :: Time
r) = Time -> Maybe Time
forall a. a -> Maybe a
Just Time
r
getR (VF x :: Double
x) = Time -> Maybe Time
forall a. a -> Maybe a
Just (Time -> Maybe Time) -> Time -> Maybe Time
forall a b. (a -> b) -> a -> b
$ Double -> Time
forall a. Real a => a -> Time
toRational Double
x
getR (VI x :: Int
x) = Time -> Maybe Time
forall a. a -> Maybe a
Just (Time -> Maybe Time) -> Time -> Maybe Time
forall a b. (a -> b) -> a -> b
$ Int -> Time
forall a. Real a => a -> Time
toRational Int
x
getR _  = Maybe Time
forall a. Maybe a
Nothing

getBlob :: Value -> Maybe [Word8]
getBlob :: Value -> Maybe [Word8]
getBlob (VX xs :: [Word8]
xs) = [Word8] -> Maybe [Word8]
forall a. a -> Maybe a
Just [Word8]
xs
getBlob _  = Maybe [Word8]
forall a. Maybe a
Nothing

compressArc :: Arc -> Pattern a -> Pattern a
compressArc :: Arc -> Pattern a -> Pattern a
compressArc (Arc s :: Time
s e :: Time
e) p :: Pattern a
p | Time
s Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
e = Pattern a
forall a. Pattern a
empty
                        | Time
s Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
|| Time
e Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> 1 = Pattern a
forall a. Pattern a
empty
                        | Time
s Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| Time
e Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Pattern a
forall a. Pattern a
empty
                        | Bool
otherwise = Time
s Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR` Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fastGap (1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/(Time
eTime -> Time -> Time
forall a. Num a => a -> a -> a
-Time
s)) Pattern a
p

compressArcTo :: Arc -> Pattern a -> Pattern a
compressArcTo :: Arc -> Pattern a -> Pattern a
compressArcTo (Arc s :: Time
s e :: Time
e) = Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
compressArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
cyclePos Time
s) (Time
e Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time -> Time
sam Time
s))

_fastGap :: Time -> Pattern a -> Pattern a
_fastGap :: Time -> Pattern a -> Pattern a
_fastGap 0 _ = Pattern a
forall a. Pattern a
empty
_fastGap r :: Time
r p :: Pattern a
p = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
splitQueries (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ 
  (Arc -> Arc) -> Pattern a -> Pattern a
forall a. (Arc -> Arc) -> Pattern a -> Pattern a
withResultArc (\(Arc s :: Time
s e :: Time
e) -> Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
sam Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
+ ((Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time -> Time
sam Time
s)Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
r'))
                             (Time -> Time
sam Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
+ ((Time
e Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time -> Time
sam Time
s)Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
r'))
                 ) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a
p {query :: Query a
query = Query a
f}
  where r' :: Time
r' = Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
r 1
        -- zero width queries of the next sam should return zero in this case..
        f :: Query a
f st :: State
st@(State a :: Arc
a _) | Arc -> Time
forall a. ArcF a -> a
start Arc
a' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time -> Time
nextSam (Arc -> Time
forall a. ArcF a -> a
start Arc
a) = []
                         | Bool
otherwise = Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
p State
st {arc :: Arc
arc = Arc
a'}
          where mungeQuery :: Time -> Time
mungeQuery t :: Time
t = Time -> Time
sam Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> Time -> Time
forall a. Ord a => a -> a -> a
min 1 (Time
r' Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time -> Time
cyclePos Time
t)
                a' :: Arc
a' = (\(Arc s :: Time
s e :: Time
e) -> Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
mungeQuery Time
s) (Time -> Time
mungeQuery Time
e)) Arc
a

-- | Shifts a pattern back in time by the given amount, expressed in cycles
rotL :: Time -> Pattern a -> Pattern a
rotL :: Time -> Pattern a -> Pattern a
rotL t :: Time
t p :: Pattern a
p = (Time -> Time) -> Pattern a -> Pattern a
forall a. (Time -> Time) -> Pattern a -> Pattern a
withResultTime (Time -> Time -> Time
forall a. Num a => a -> a -> a
subtract Time
t) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Time -> Time) -> Pattern a -> Pattern a
forall a. (Time -> Time) -> Pattern a -> Pattern a
withQueryTime (Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
t) Pattern a
p

-- | Shifts a pattern forward in time by the given amount, expressed in cycles
rotR :: Time -> Pattern a -> Pattern a
rotR :: Time -> Pattern a -> Pattern a
rotR t :: Time
t = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
rotL (Time -> Time
forall a. Num a => a -> a
negate Time
t)

-- ** Event filters

-- | Remove events from patterns that to not meet the given test
filterValues :: (a -> Bool) -> Pattern a -> Pattern a
filterValues :: (a -> Bool) -> Pattern a -> Pattern a
filterValues f :: a -> Bool
f p :: Pattern a
p = Pattern a
p {query :: Query a
query = (EventF Arc a -> Bool) -> [EventF Arc a] -> [EventF Arc a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Bool
f (a -> Bool) -> (EventF Arc a -> a) -> EventF Arc a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventF Arc a -> a
forall a b. EventF a b -> b
value) ([EventF Arc a] -> [EventF Arc a]) -> Query a -> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
p}

-- | Turns a pattern of 'Maybe' values into a pattern of values,
-- dropping the events of 'Nothing'.
filterJust :: Pattern (Maybe a) -> Pattern a
filterJust :: Pattern (Maybe a) -> Pattern a
filterJust p :: Pattern (Maybe a)
p = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> Pattern (Maybe a) -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe a -> Bool) -> Pattern (Maybe a) -> Pattern (Maybe a)
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Pattern (Maybe a)
p

-- formerly known as playWhen
filterWhen :: (Time -> Bool) -> Pattern a -> Pattern a
filterWhen :: (Time -> Bool) -> Pattern a -> Pattern a
filterWhen test :: Time -> Bool
test p :: Pattern a
p = Pattern a
p {query :: Query a
query = (Event a -> Bool) -> [Event a] -> [Event a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Time -> Bool
test (Time -> Bool) -> (Event a -> Time) -> Event a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Time
forall a. Event a -> Time
wholeStart) ([Event a] -> [Event a]) -> Query a -> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
p}

filterOnsets :: Pattern a -> Pattern a
filterOnsets :: Pattern a -> Pattern a
filterOnsets p :: Pattern a
p = Pattern a
p {query :: Query a
query = (Event a -> Bool) -> [Event a] -> [Event a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\e :: Event a
e -> Event a -> Time
forall a. Event a -> Time
eventPartStart Event a
e Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Event a -> Time
forall a. Event a -> Time
wholeStart Event a
e) ([Event a] -> [Event a]) -> Query a -> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> Query a
forall a. Pattern a -> Query a
query (Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
filterDigital Pattern a
p)}

filterEvents :: (Event a -> Bool) -> Pattern a -> Pattern a
filterEvents :: (Event a -> Bool) -> Pattern a -> Pattern a
filterEvents f :: Event a -> Bool
f p :: Pattern a
p = Pattern a
p {query :: Query a
query = (Event a -> Bool) -> [Event a] -> [Event a]
forall a. (a -> Bool) -> [a] -> [a]
filter Event a -> Bool
f ([Event a] -> [Event a]) -> Query a -> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
p}

filterDigital :: Pattern a -> Pattern a
filterDigital :: Pattern a -> Pattern a
filterDigital = (Event a -> Bool) -> Pattern a -> Pattern a
forall a. (Event a -> Bool) -> Pattern a -> Pattern a
filterEvents Event a -> Bool
forall a. Event a -> Bool
isDigital

filterAnalog :: Pattern a -> Pattern a
filterAnalog :: Pattern a -> Pattern a
filterAnalog = (Event a -> Bool) -> Pattern a -> Pattern a
forall a. (Event a -> Bool) -> Pattern a -> Pattern a
filterEvents Event a -> Bool
forall a. Event a -> Bool
isAnalog

playFor :: Time -> Time -> Pattern a -> Pattern a
playFor :: Time -> Time -> Pattern a -> Pattern a
playFor s :: Time
s e :: Time
e = (Time -> Bool) -> Pattern a -> Pattern a
forall a. (Time -> Bool) -> Pattern a -> Pattern a
filterWhen (\t :: Time
t -> (Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
s) Bool -> Bool -> Bool
&& (Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
e))

-- ** Temporal parameter helpers

tParam :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam f :: t1 -> t2 -> Pattern a
f tv :: Pattern t1
tv p :: t2
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (t1 -> t2 -> Pattern a
`f` t2
p) (t1 -> Pattern a) -> Pattern t1 -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern t1
tv

tParam2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d
tParam2 :: (a -> b -> c -> Pattern d)
-> Pattern a -> Pattern b -> c -> Pattern d
tParam2 f :: a -> b -> c -> Pattern d
f a :: Pattern a
a b :: Pattern b
b p :: c
p = Pattern (Pattern d) -> Pattern d
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern d) -> Pattern d)
-> Pattern (Pattern d) -> Pattern d
forall a b. (a -> b) -> a -> b
$ (\x :: a
x y :: b
y -> a -> b -> c -> Pattern d
f a
x b
y c
p) (a -> b -> Pattern d) -> Pattern a -> Pattern (b -> Pattern d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
a Pattern (b -> Pattern d) -> Pattern b -> Pattern (Pattern d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern b
b

tParam3 :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e)
tParam3 :: (a -> b -> c -> Pattern d -> Pattern e)
-> Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e
tParam3 f :: a -> b -> c -> Pattern d -> Pattern e
f a :: Pattern a
a b :: Pattern b
b c :: Pattern c
c p :: Pattern d
p = Pattern (Pattern e) -> Pattern e
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern e) -> Pattern e)
-> Pattern (Pattern e) -> Pattern e
forall a b. (a -> b) -> a -> b
$ (\x :: a
x y :: b
y z :: c
z -> a -> b -> c -> Pattern d -> Pattern e
f a
x b
y c
z Pattern d
p) (a -> b -> c -> Pattern e)
-> Pattern a -> Pattern (b -> c -> Pattern e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
a Pattern (b -> c -> Pattern e)
-> Pattern b -> Pattern (c -> Pattern e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern b
b Pattern (c -> Pattern e) -> Pattern c -> Pattern (Pattern e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern c
c

tParamSqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c)
tParamSqueeze :: (a -> Pattern b -> Pattern c)
-> Pattern a -> Pattern b -> Pattern c
tParamSqueeze f :: a -> Pattern b -> Pattern c
f tv :: Pattern a
tv p :: Pattern b
p = Pattern (Pattern c) -> Pattern c
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern c) -> Pattern c)
-> Pattern (Pattern c) -> Pattern c
forall a b. (a -> b) -> a -> b
$ (a -> Pattern b -> Pattern c
`f` Pattern b
p) (a -> Pattern c) -> Pattern a -> Pattern (Pattern c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
tv

-- | Mark values in the first pattern which match with at least one
-- value in the second pattern.
matchManyToOne :: (b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b)
matchManyToOne :: (b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b)
matchManyToOne f :: b -> a -> Bool
f pa :: Pattern a
pa pb :: Pattern b
pb = Pattern a
pa {query :: Query (Bool, b)
query = Query (Bool, b)
q}
  where q :: Query (Bool, b)
q st :: State
st = (EventF Arc b -> EventF Arc (Bool, b))
-> [EventF Arc b] -> [EventF Arc (Bool, b)]
forall a b. (a -> b) -> [a] -> [b]
map EventF Arc b -> EventF Arc (Bool, b)
match ([EventF Arc b] -> [EventF Arc (Bool, b)])
-> [EventF Arc b] -> [EventF Arc (Bool, b)]
forall a b. (a -> b) -> a -> b
$ Pattern b -> Query b
forall a. Pattern a -> Query a
query Pattern b
pb State
st
          where
            match :: EventF Arc b -> EventF Arc (Bool, b)
match (ex :: EventF Arc b
ex@(Event xContext :: Context
xContext xWhole :: Maybe Arc
xWhole xPart :: Arc
xPart x :: b
x)) =
              Context -> Maybe Arc -> Arc -> (Bool, b) -> EventF Arc (Bool, b)
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts ([Context] -> Context) -> [Context] -> Context
forall a b. (a -> b) -> a -> b
$ Context
xContextContext -> [Context] -> [Context]
forall a. a -> [a] -> [a]
:((EventF Arc a -> Context) -> [EventF Arc a] -> [Context]
forall a b. (a -> b) -> [a] -> [b]
map EventF Arc a -> Context
forall a b. EventF a b -> Context
context [EventF Arc a]
as')) Maybe Arc
xWhole Arc
xPart ((a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (b -> a -> Bool
f b
x) ((EventF Arc a -> a) -> [EventF Arc a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map EventF Arc a -> a
forall a b. EventF a b -> b
value ([EventF Arc a] -> [a]) -> [EventF Arc a] -> [a]
forall a b. (a -> b) -> a -> b
$ [EventF Arc a]
as'), b
x)
                where as' :: [EventF Arc a]
as' = Time -> [EventF Arc a]
as (Time -> [EventF Arc a]) -> Time -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ EventF Arc b -> Arc
forall a. Event a -> Arc
wholeOrPart EventF Arc b
ex
            as :: Time -> [EventF Arc a]
as s :: Time
s = Pattern a -> Query a
forall a. Pattern a -> Query a
query Pattern a
pa Query a -> Query a
forall a b. (a -> b) -> a -> b
$ Time -> State
fQuery Time
s
            fQuery :: Time -> State
fQuery s :: Time
s = State
st {arc :: Arc
arc = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s Time
s}