--------------------------------------------------------------------------------
{-# LANGUAGE DeriveFoldable    #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
module Patat.Transition
    ( Duration (..)
    , threadDelayDuration
    , TransitionGen
    , TransitionId
    , TransitionInstance (..)
    , parseTransitionSettings
    , newTransition
    , stepTransition
    ) where


--------------------------------------------------------------------------------
import qualified Data.Aeson.Extended         as A
import qualified Data.Aeson.TH.Extended      as A
import           Data.Bifunctor              (first)
import qualified Data.HashMap.Strict         as HMS
import           Data.List.NonEmpty          (NonEmpty (..))
import qualified Data.List.NonEmpty          as NonEmpty
import           Data.Text                   (Text)
import qualified Data.Text                   as T
import           Data.Traversable            (for)
import           Patat.Presentation.Settings (TransitionSettings (..))
import qualified Patat.Transition.Dissolve   as Dissolve
import           Patat.Transition.Internal
import qualified Patat.Transition.Matrix     as Matrix
import qualified Patat.Transition.SlideLeft  as SlideLeft
import           System.Random               (uniformR)


--------------------------------------------------------------------------------
data RandomTransitionSettings = RandomTransitionSettings
    { RandomTransitionSettings -> Maybe (NonEmpty TransitionSettings)
rtsItems :: Maybe (NonEmpty TransitionSettings)
    }


--------------------------------------------------------------------------------
$(A.deriveFromJSON A.dropPrefixOptions ''RandomTransitionSettings)


--------------------------------------------------------------------------------
random :: NonEmpty TransitionGen -> TransitionGen
random :: NonEmpty TransitionGen -> TransitionGen
random NonEmpty TransitionGen
items Size
size Matrix
matrix0 Matrix
matrix1 StdGen
rg0 =
    let (Int
idx, StdGen
rg1) = (Int, Int) -> StdGen -> (Int, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
uniformR (Int
0, NonEmpty TransitionGen -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty TransitionGen
items Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) StdGen
rg0 in
    (NonEmpty TransitionGen
items NonEmpty TransitionGen -> Int -> TransitionGen
forall a. HasCallStack => NonEmpty a -> Int -> a
NonEmpty.!! Int
idx) Size
size Matrix
matrix0 Matrix
matrix1 StdGen
rg1


--------------------------------------------------------------------------------
transitions :: NonEmpty (Text, Transition)
transitions :: NonEmpty (Text, Transition)
transitions =
    (Text
"dissolve",  (Config -> TransitionGen) -> Transition
forall conf. FromJSON conf => (conf -> TransitionGen) -> Transition
Transition Config -> TransitionGen
Dissolve.transition) (Text, Transition)
-> [(Text, Transition)] -> NonEmpty (Text, Transition)
forall a. a -> [a] -> NonEmpty a
:|
    (Text
"matrix",    (Config -> TransitionGen) -> Transition
forall conf. FromJSON conf => (conf -> TransitionGen) -> Transition
Transition Config -> TransitionGen
Matrix.transition) (Text, Transition) -> [(Text, Transition)] -> [(Text, Transition)]
forall a. a -> [a] -> [a]
:
    (Text
"slideLeft", (Config -> TransitionGen) -> Transition
forall conf. FromJSON conf => (conf -> TransitionGen) -> Transition
Transition Config -> TransitionGen
SlideLeft.transition) (Text, Transition) -> [(Text, Transition)] -> [(Text, Transition)]
forall a. a -> [a] -> [a]
: []


--------------------------------------------------------------------------------
transitionTable :: HMS.HashMap Text Transition
transitionTable :: HashMap Text Transition
transitionTable = ((Text, Transition) -> HashMap Text Transition)
-> NonEmpty (Text, Transition) -> HashMap Text Transition
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Text -> Transition -> HashMap Text Transition)
-> (Text, Transition) -> HashMap Text Transition
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Transition -> HashMap Text Transition
forall k v. Hashable k => k -> v -> HashMap k v
HMS.singleton) NonEmpty (Text, Transition)
transitions


--------------------------------------------------------------------------------
parseTransitionSettings
    :: TransitionSettings -> Either String TransitionGen
parseTransitionSettings :: TransitionSettings -> Either String TransitionGen
parseTransitionSettings TransitionSettings
ts
    -- Random is treated specially here.
    | Text
ty Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"random" = (NonEmpty TransitionGen -> TransitionGen)
-> Either String (NonEmpty TransitionGen)
-> Either String TransitionGen
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty TransitionGen -> TransitionGen
random (Either String (NonEmpty TransitionGen)
 -> Either String TransitionGen)
-> Either String (NonEmpty TransitionGen)
-> Either String TransitionGen
forall a b. (a -> b) -> a -> b
$ do
        RandomTransitionSettings
settings <- Result RandomTransitionSettings
-> Either String RandomTransitionSettings
forall a. Result a -> Either String a
A.resultToEither (Result RandomTransitionSettings
 -> Either String RandomTransitionSettings)
-> (Object -> Result RandomTransitionSettings)
-> Object
-> Either String RandomTransitionSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result RandomTransitionSettings
forall a. FromJSON a => Value -> Result a
A.fromJSON (Value -> Result RandomTransitionSettings)
-> (Object -> Value) -> Object -> Result RandomTransitionSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
A.Object (Object -> Either String RandomTransitionSettings)
-> Object -> Either String RandomTransitionSettings
forall a b. (a -> b) -> a -> b
$ TransitionSettings -> Object
tsParams TransitionSettings
ts
        case RandomTransitionSettings -> Maybe (NonEmpty TransitionSettings)
rtsItems RandomTransitionSettings
settings of
            -- Items specified: parse those
            Just NonEmpty TransitionSettings
items -> (TransitionSettings -> Either String TransitionGen)
-> NonEmpty TransitionSettings
-> Either String (NonEmpty TransitionGen)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse TransitionSettings -> Either String TransitionGen
parseTransitionSettings NonEmpty TransitionSettings
items
            -- No items specified: parse default transition settings.
            Maybe (NonEmpty TransitionSettings)
Nothing -> NonEmpty (Text, Transition)
-> ((Text, Transition) -> Either String TransitionGen)
-> Either String (NonEmpty TransitionGen)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for NonEmpty (Text, Transition)
transitions (((Text, Transition) -> Either String TransitionGen)
 -> Either String (NonEmpty TransitionGen))
-> ((Text, Transition) -> Either String TransitionGen)
-> Either String (NonEmpty TransitionGen)
forall a b. (a -> b) -> a -> b
$ \(Text
typ, Transition
_) -> TransitionSettings -> Either String TransitionGen
parseTransitionSettings
                TransitionSettings {tsType :: Text
tsType = Text
typ, tsParams :: Object
tsParams = Object
forall a. Monoid a => a
mempty}
    -- Found the transition type.
    | Just (Transition conf -> TransitionGen
f) <- Text -> HashMap Text Transition -> Maybe Transition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
ty HashMap Text Transition
transitionTable =
        (conf -> TransitionGen)
-> Either String conf -> Either String TransitionGen
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (conf -> TransitionGen
f (conf -> TransitionGen) -> conf -> TransitionGen
forall a b. (a -> b) -> a -> b
$) (Either String conf -> Either String TransitionGen)
-> (Object -> Either String conf)
-> Object
-> Either String TransitionGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> Either String conf -> Either String conf
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
err ->
            String
"could not parse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" transition: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err) (Either String conf -> Either String conf)
-> (Object -> Either String conf) -> Object -> Either String conf
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Result conf -> Either String conf
forall a. Result a -> Either String a
A.resultToEither (Result conf -> Either String conf)
-> (Object -> Result conf) -> Object -> Either String conf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result conf
forall a. FromJSON a => Value -> Result a
A.fromJSON (Value -> Result conf)
-> (Object -> Value) -> Object -> Result conf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
A.Object (Object -> Either String TransitionGen)
-> Object -> Either String TransitionGen
forall a b. (a -> b) -> a -> b
$ TransitionSettings -> Object
tsParams TransitionSettings
ts
    -- Not found, error.
    | Bool
otherwise = String -> Either String TransitionGen
forall a b. a -> Either a b
Left (String -> Either String TransitionGen)
-> String -> Either String TransitionGen
forall a b. (a -> b) -> a -> b
$ String
"unknown transition type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
ty
  where
    ty :: Text
ty = TransitionSettings -> Text
tsType TransitionSettings
ts