{-# LANGUAGE CPP, OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   : (C) 2015 Dimitri Sabadie
-- License     : BSD3
--
-- Maintainer  : Dimitri Sabadie <dimitri.sabadie@gmail.com>
-- Stability   : experimental
-- Portability : portable
--
-- This module defines 'Spline's and related functions. Because a 'Spline'
-- requires 'Key's, the "Data.Spline.Key" module is also exported.
-----------------------------------------------------------------------------

module Data.Spline.Curve (
    -- * Splines
    Spline
  , splineKeys
    -- * Building splines
  , spline
    -- * Sampling splines
  , sample
    -- * Re-exported
  , module Data.Spline.Key
  ) where

import Control.Monad ( guard )
import Data.Aeson
import Data.List ( sortBy )
import Data.Ord ( comparing )
import Data.Spline.Key
import Data.Vector ( Vector, (!?), fromList )
import Linear ( Additive )
import GHC.Generics ( Generic )

-- |A @'Spline' a s@ is a collection of 'Key's with associated interpolation
-- modes.
--
-- Given two 'Key's which indices are /i/ and /i+1/, the interpolation mode on
-- the resulting curve is performed using the interpolation mode of the key /i/.
-- Thus, the interpolation mode of the latest key might be ignored. There’s an
-- exception, though, when using the 'Bezier' interpolation mode. Feel free
-- to dig in the "Key" documentation.
newtype Spline a s = Spline {
    -- |Extract the 'Key's.
    Spline a s -> Vector (Key (a s))
splineKeys :: Vector (Key (a s))
  } deriving (Spline a s -> Spline a s -> Bool
(Spline a s -> Spline a s -> Bool)
-> (Spline a s -> Spline a s -> Bool) -> Eq (Spline a s)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (a :: * -> *) s.
Eq (a s) =>
Spline a s -> Spline a s -> Bool
/= :: Spline a s -> Spline a s -> Bool
$c/= :: forall (a :: * -> *) s.
Eq (a s) =>
Spline a s -> Spline a s -> Bool
== :: Spline a s -> Spline a s -> Bool
$c== :: forall (a :: * -> *) s.
Eq (a s) =>
Spline a s -> Spline a s -> Bool
Eq,(forall x. Spline a s -> Rep (Spline a s) x)
-> (forall x. Rep (Spline a s) x -> Spline a s)
-> Generic (Spline a s)
forall x. Rep (Spline a s) x -> Spline a s
forall x. Spline a s -> Rep (Spline a s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (a :: * -> *) s x. Rep (Spline a s) x -> Spline a s
forall (a :: * -> *) s x. Spline a s -> Rep (Spline a s) x
$cto :: forall (a :: * -> *) s x. Rep (Spline a s) x -> Spline a s
$cfrom :: forall (a :: * -> *) s x. Spline a s -> Rep (Spline a s) x
Generic,a -> Spline a b -> Spline a a
(a -> b) -> Spline a a -> Spline a b
(forall a b. (a -> b) -> Spline a a -> Spline a b)
-> (forall a b. a -> Spline a b -> Spline a a)
-> Functor (Spline a)
forall a b. a -> Spline a b -> Spline a a
forall a b. (a -> b) -> Spline a a -> Spline a b
forall (a :: * -> *) a b.
Functor a =>
a -> Spline a b -> Spline a a
forall (a :: * -> *) a b.
Functor a =>
(a -> b) -> Spline a a -> Spline a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Spline a b -> Spline a a
$c<$ :: forall (a :: * -> *) a b.
Functor a =>
a -> Spline a b -> Spline a a
fmap :: (a -> b) -> Spline a a -> Spline a b
$cfmap :: forall (a :: * -> *) a b.
Functor a =>
(a -> b) -> Spline a a -> Spline a b
Functor,Int -> Spline a s -> ShowS
[Spline a s] -> ShowS
Spline a s -> String
(Int -> Spline a s -> ShowS)
-> (Spline a s -> String)
-> ([Spline a s] -> ShowS)
-> Show (Spline a s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (a :: * -> *) s. Show (a s) => Int -> Spline a s -> ShowS
forall (a :: * -> *) s. Show (a s) => [Spline a s] -> ShowS
forall (a :: * -> *) s. Show (a s) => Spline a s -> String
showList :: [Spline a s] -> ShowS
$cshowList :: forall (a :: * -> *) s. Show (a s) => [Spline a s] -> ShowS
show :: Spline a s -> String
$cshow :: forall (a :: * -> *) s. Show (a s) => Spline a s -> String
showsPrec :: Int -> Spline a s -> ShowS
$cshowsPrec :: forall (a :: * -> *) s. Show (a s) => Int -> Spline a s -> ShowS
Show)

instance (FromJSON (a s), Ord s) => FromJSON ((a s -> s) -> Spline a s) where
  parseJSON :: Value -> Parser ((a s -> s) -> Spline a s)
parseJSON Value
value = do
    [Key (a s)]
keys <- Value -> Parser [Key (a s)]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value
    ((a s -> s) -> Spline a s) -> Parser ((a s -> s) -> Spline a s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((a s -> s) -> Spline a s) -> Parser ((a s -> s) -> Spline a s))
-> ((a s -> s) -> Spline a s) -> Parser ((a s -> s) -> Spline a s)
forall a b. (a -> b) -> a -> b
$ \a s -> s
sampler -> (a s -> s) -> [Key (a s)] -> Spline a s
forall s (a :: * -> *).
Ord s =>
(a s -> s) -> [Key (a s)] -> Spline a s
spline a s -> s
sampler [Key (a s)]
keys

instance (ToJSON (a s)) => ToJSON (Spline a s) where
#if MIN_VERSION_aeson(0,10,0)
  toJSON :: Spline a s -> Value
toJSON     = Options -> Spline a s -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
  toEncoding :: Spline a s -> Encoding
toEncoding = Options -> Spline a s -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions
#else
  toJSON = Array . fmap toJSON . splineKeys
#endif

-- |Build a @'Spline' a s@.
--
-- @a s@ is the type held by 'Key's. For instance, @'V2' Float@.
--
-- The first argument of the function, which has type @a s -> s@, is a function
-- used to extract the sampling value of each 'Key's. In most cases, that value
-- represents the time or the frame of a simulation. That value is used to
-- perform sampling comparison.
spline :: (Ord s)
       => (a s -> s)
       -> [Key (a s)]
       -> Spline a s
spline :: (a s -> s) -> [Key (a s)] -> Spline a s
spline a s -> s
sampler = Vector (Key (a s)) -> Spline a s
forall (a :: * -> *) s. Vector (Key (a s)) -> Spline a s
Spline (Vector (Key (a s)) -> Spline a s)
-> ([Key (a s)] -> Vector (Key (a s))) -> [Key (a s)] -> Spline a s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key (a s)] -> Vector (Key (a s))
forall a. [a] -> Vector a
fromList ([Key (a s)] -> Vector (Key (a s)))
-> ([Key (a s)] -> [Key (a s)])
-> [Key (a s)]
-> Vector (Key (a s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key (a s) -> Key (a s) -> Ordering) -> [Key (a s)] -> [Key (a s)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Key (a s) -> s) -> Key (a s) -> Key (a s) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Key (a s) -> s) -> Key (a s) -> Key (a s) -> Ordering)
-> (Key (a s) -> s) -> Key (a s) -> Key (a s) -> Ordering
forall a b. (a -> b) -> a -> b
$ a s -> s
sampler (a s -> s) -> (Key (a s) -> a s) -> Key (a s) -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key (a s) -> a s
forall a. Key a -> a
keyValue)

-- |Sample a 'Spline' at a given 's' sampling value. If no sample exists,
-- yields 'Nothing'.
--
-- The first parameter is a /sampler/ function used to extract a comparison
-- value. For most curves, the reflected value should be the time or the frame.
sample :: (Additive a,Floating s,Ord s)
       => (a s -> s)
       -> Spline a s
       -> s
       -> Maybe (a s)
sample :: (a s -> s) -> Spline a s -> s -> Maybe (a s)
sample a s -> s
sampler (Spline Vector (Key (a s))
keys) s
at = do
  Int
i <- (Key (a s) -> Ordering) -> Vector (Key (a s)) -> Maybe Int
forall a. (a -> Ordering) -> Vector a -> Maybe Int
bsearchLower (\Key (a s)
k -> s -> s -> Ordering
forall a. Ord a => a -> a -> Ordering
compare s
at (a s -> s
sampler (a s -> s) -> a s -> s
forall a b. (a -> b) -> a -> b
$ Key (a s) -> a s
forall a. Key a -> a
keyValue Key (a s)
k)) Vector (Key (a s))
keys
  Key (a s)
k0 <- Vector (Key (a s))
keys Vector (Key (a s)) -> Int -> Maybe (Key (a s))
forall a. Vector a -> Int -> Maybe a
!? Int
i
  Key (a s)
k1 <- Vector (Key (a s))
keys Vector (Key (a s)) -> Int -> Maybe (Key (a s))
forall a. Vector a -> Int -> Maybe a
!? (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  a s -> Maybe (a s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a s -> Maybe (a s)) -> a s -> Maybe (a s)
forall a b. (a -> b) -> a -> b
$ s -> Key (a s) -> Key (a s) -> a s
forall (a :: * -> *) s.
(Additive a, Floating s) =>
s -> Key (a s) -> Key (a s) -> a s
interpolateKeys ((a s -> s) -> s -> Key (a s) -> Key (a s) -> s
forall s (a :: * -> *).
Fractional s =>
(a s -> s) -> s -> Key (a s) -> Key (a s) -> s
normalizeSampling a s -> s
sampler s
at Key (a s)
k0 Key (a s)
k1) Key (a s)
k0 Key (a s)
k1

-- Helper binary search that searches the ceiling index for the
-- value to be searched according to the predicate.
bsearchLower :: (a -> Ordering) -> Vector a -> Maybe Int
bsearchLower :: (a -> Ordering) -> Vector a -> Maybe Int
bsearchLower a -> Ordering
p Vector a
v = Int -> Int -> Maybe Int
go Int
0 (Vector a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector a
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  where
    go :: Int -> Int -> Maybe Int
go Int
start Int
end = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
start Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
end)
        a
ma <- Vector a
v Vector a -> Int -> Maybe a
forall a. Vector a -> Int -> Maybe a
!? Int
m
        a
ma1 <- Vector a
v Vector a -> Int -> Maybe a
forall a. Vector a -> Int -> Maybe a
!? Int -> Int
forall a. Enum a => a -> a
succ Int
m
        case a -> Ordering
p a
ma of
          Ordering
LT -> Int -> Int -> Maybe Int
go Int
start (Int -> Int
forall a. Enum a => a -> a
pred Int
m)
          Ordering
EQ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
m
          Ordering
GT -> if a -> Ordering
p a
ma1 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
m else Int -> Int -> Maybe Int
go (Int -> Int
forall a. Enum a => a -> a
succ Int
m) Int
end
      where
        m :: Int
m = (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
start) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2