{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   : (C) 2015 Dimitri Sabadie
-- License     : BSD3
--
-- Maintainer  : Dimitri Sabadie <dimitri.sabadie@gmail.com>
-- Stability   : experimental
-- Portability : portable
-----------------------------------------------------------------------------

module Data.Spline.Key (
    -- * Key type
    Key(..)
  , keyValue
    -- * Interpolation
  , interpolateKeys
  , normalizeSampling
  ) where

import Data.Aeson
import Data.Text ( Text )
import Linear

-- |A 'Key' is a point on the spline with extra information added. It can be,
-- for instance, left and right handles for a 'Bezier' curve, or whatever the
-- interpolation might need.
--
-- @H'old' v@ is used to express no interpolation and holds its latest value
-- until the next key.
--
-- @'Linear' v@ represents a linear interpolation until the next key.
--
-- @'Cosine' v@ represents a cosine interpolation until the next key.
--
-- @'CubicHermite' v@ represents a cubic hermitian interpolation until the next
-- key.
--
-- @'Bezier' l v r@ represents a cubic 'Bezier' interpolation, where 'l' refers
-- to the input – left – tangent of the key and 'r' is the
-- output – right – tangent of the key.
data Key a
  = Hold a
  | Linear a
  | Cosine a
  | CubicHermite a
  | Bezier a a a
    deriving (Key a -> Key a -> Bool
(Key a -> Key a -> Bool) -> (Key a -> Key a -> Bool) -> Eq (Key a)
forall a. Eq a => Key a -> Key a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key a -> Key a -> Bool
$c/= :: forall a. Eq a => Key a -> Key a -> Bool
== :: Key a -> Key a -> Bool
$c== :: forall a. Eq a => Key a -> Key a -> Bool
Eq,a -> Key b -> Key a
(a -> b) -> Key a -> Key b
(forall a b. (a -> b) -> Key a -> Key b)
-> (forall a b. a -> Key b -> Key a) -> Functor Key
forall a b. a -> Key b -> Key a
forall a b. (a -> b) -> Key a -> Key b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Key b -> Key a
$c<$ :: forall a b. a -> Key b -> Key a
fmap :: (a -> b) -> Key a -> Key b
$cfmap :: forall a b. (a -> b) -> Key a -> Key b
Functor,Int -> Key a -> ShowS
[Key a] -> ShowS
Key a -> String
(Int -> Key a -> ShowS)
-> (Key a -> String) -> ([Key a] -> ShowS) -> Show (Key a)
forall a. Show a => Int -> Key a -> ShowS
forall a. Show a => [Key a] -> ShowS
forall a. Show a => Key a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key a] -> ShowS
$cshowList :: forall a. Show a => [Key a] -> ShowS
show :: Key a -> String
$cshow :: forall a. Show a => Key a -> String
showsPrec :: Int -> Key a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Key a -> ShowS
Show)

instance (FromJSON a) => FromJSON (Key a) where
  parseJSON :: Value -> Parser (Key a)
parseJSON = String -> (Object -> Parser (Key a)) -> Value -> Parser (Key a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"key" ((Object -> Parser (Key a)) -> Value -> Parser (Key a))
-> (Object -> Parser (Key a)) -> Value -> Parser (Key a)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    String
interpolation :: String <- Object
o Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"interpolation"
    a
value <- Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"value"
    if
      | String
interpolation String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"hold"          -> Key a -> Parser (Key a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Key a
forall a. a -> Key a
Hold a
value)
      | String
interpolation String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"linear"        -> Key a -> Parser (Key a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Key a
forall a. a -> Key a
Linear a
value)
      | String
interpolation String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"cosine"        -> Key a -> Parser (Key a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Key a
forall a. a -> Key a
Cosine a
value)
      | String
interpolation String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"cubic-hermite" -> Key a -> Parser (Key a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Key a
forall a. a -> Key a
CubicHermite a
value)
      | String
interpolation String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"bezier" -> do
          a
left <- Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"left"
          a
right <- Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"right"
          Key a -> Parser (Key a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key a -> Parser (Key a)) -> Key a -> Parser (Key a)
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> Key a
forall a. a -> a -> a -> Key a
Bezier a
left a
value a
right
      | Bool
otherwise                        -> String -> Parser (Key a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unknown interpolation mode"

instance (ToJSON a) => ToJSON (Key a) where
  toJSON :: Key a -> Value
toJSON Key a
k = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [Text
"value" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
value,Text
"interpolation" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
interpolation] [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
tangents
    where
      value :: a
value = Key a -> a
forall a. Key a -> a
keyValue Key a
k
      interpolation :: Text
interpolation = Key a -> Text
forall a. Key a -> Text
keyInterpolation Key a
k
      tangents :: [Pair]
tangents = case Key a
k of
        Bezier a
l a
_ a
r -> [Text
"left" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
l,Text
"right" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
r]
        Key a
_            -> []

-- |Extract the value out of a 'Key'.
keyValue :: Key a -> a
keyValue :: Key a -> a
keyValue Key a
k = case Key a
k of
  Hold a
a         -> a
a
  Linear a
a       -> a
a
  Cosine a
a       -> a
a
  CubicHermite a
a -> a
a
  Bezier a
_ a
a a
_   -> a
a

-- |Extract the interpolation mode from a 'Key'.
keyInterpolation :: Key a -> Text
keyInterpolation :: Key a -> Text
keyInterpolation Key a
k = case Key a
k of
  Hold{}         -> Text
"hold"
  Linear{}       -> Text
"linear"
  Cosine{}       -> Text
"cosine"
  CubicHermite{} -> Text
"cubic-hermite"
  Bezier{}       -> Text
"bezier"

-- |@'interpolateKeys' t start end@ interpolates between 'start' and 'end' using
-- 's' as a normalized sampling value.
--
-- Satisfies the following laws:
--
-- @
--   'interpolateKeys' 0 start _ = start
--   'interpolateKeys' 1 _ end   = end
-- @
interpolateKeys :: (Additive a,Floating s) => s -> Key (a s) -> Key (a s) -> a s
interpolateKeys :: s -> Key (a s) -> Key (a s) -> a s
interpolateKeys s
s Key (a s)
start Key (a s)
end = case Key (a s)
start of
    Hold a s
k         -> a s
k
    Linear a s
k       -> s -> a s -> a s -> a s
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp s
s a s
b a s
k
    Cosine a s
k       -> s -> a s -> a s -> a s
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp ((s
1 s -> s -> s
forall a. Num a => a -> a -> a
- s -> s
forall a. Floating a => a -> a
cos (s
s s -> s -> s
forall a. Num a => a -> a -> a
* s
forall a. Floating a => a
pi)) s -> s -> s
forall a. Num a => a -> a -> a
* s
0.5) a s
b a s
k
    CubicHermite a s
k -> s -> a s -> a s -> a s
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp (s
s s -> s -> s
forall a. Num a => a -> a -> a
* s
s s -> s -> s
forall a. Num a => a -> a -> a
* (s
3 s -> s -> s
forall a. Num a => a -> a -> a
- s
2 s -> s -> s
forall a. Num a => a -> a -> a
* s
s)) a s
b a s
k
    Bezier a s
_ a s
k0 a s
r0   -> case Key (a s)
end of
      Bezier a s
l1 a s
k1 a s
_ -> s -> a s -> a s -> a s -> a s -> a s
forall (a :: * -> *) s.
(Additive a, Floating s) =>
s -> a s -> a s -> a s -> a s -> a s
interpolateBezier s
s a s
k0 a s
r0 a s
l1 a s
k1
      Key (a s)
_              -> s -> a s -> a s -> a s -> a s -> a s
forall (a :: * -> *) s.
(Additive a, Floating s) =>
s -> a s -> a s -> a s -> a s -> a s
interpolateBezier s
s a s
k0 a s
r0 a s
r0 a s
b
  where
    b :: a s
b = Key (a s) -> a s
forall a. Key a -> a
keyValue Key (a s)
end

-- @'interpolateBezier' s k0 r0 l1 k1@ performs a 'Bezier' interpolation
-- between keys 'k0' and 'k1' using their respective right and left tangents.
interpolateBezier :: (Additive a,Floating s)
                  => s
                  -> a s
                  -> a s
                  -> a s
                  -> a s
                  -> a s
interpolateBezier :: s -> a s -> a s -> a s -> a s -> a s
interpolateBezier s
s a s
k0 a s
r0 a s
l1 a s
k1 =
    a s
k0 a s -> s -> a s
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* s
ms3 a s -> a s -> a s
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ a s
r0 a s -> s -> a s
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* (s
3 s -> s -> s
forall a. Num a => a -> a -> a
* s
ms2 s -> s -> s
forall a. Num a => a -> a -> a
* s
s) a s -> a s -> a s
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ a s
l1 a s -> s -> a s
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* (s
3 s -> s -> s
forall a. Num a => a -> a -> a
* s
ms s -> s -> s
forall a. Num a => a -> a -> a
* s
s2) a s -> a s -> a s
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ a s
k1 a s -> s -> a s
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* s
s3
  where
    ms :: s
ms = s
1 s -> s -> s
forall a. Num a => a -> a -> a
- s
s
    ms2 :: s
ms2 = s
ms s -> s -> s
forall a. Num a => a -> a -> a
* s
ms
    ms3 :: s
ms3 = s
ms2 s -> s -> s
forall a. Num a => a -> a -> a
* s
ms
    s2 :: s
s2 = s
s s -> s -> s
forall a. Num a => a -> a -> a
* s
s
    s3 :: s
s3 = s
s2 s -> s -> s
forall a. Num a => a -> a -> a
* s
s

-- |Normalize a sampling value by clamping and scaling it between two 'Key's.
--
-- The following laws should be satisfied in order to get a coherent output:
--
-- @
--   sampler :: a s -> s
--
--   sampler ('keyValue' k1) <= s >= sampler ('keyValue' k0)
--   0 <= 'normalizeSampling' sampler s k0 k1 <= 1
-- @
normalizeSampling :: (Fractional s)
                  => (a s -> s)
                  -> s
                  -> Key (a s)
                  -> Key (a s)
                  -> s
normalizeSampling :: (a s -> s) -> s -> Key (a s) -> Key (a s) -> s
normalizeSampling a s -> s
sampler s
s Key (a s)
k0 Key (a s)
k1 = (s
s s -> s -> s
forall a. Num a => a -> a -> a
- s
s0) s -> s -> s
forall a. Fractional a => a -> a -> a
/ (s
s1 s -> s -> s
forall a. Num a => a -> a -> a
- s
s0)
  where
    s0 :: s
s0 = a s -> s
sampler (Key (a s) -> a s
forall a. Key a -> a
keyValue Key (a s)
k0)
    s1 :: s
s1 = a s -> s
sampler (Key (a s) -> a s
forall a. Key a -> a
keyValue Key (a s)
k1)