{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Copyright  : (c) Ivan Perez and Manuel Baerenz, 2016
-- License    : BSD3
-- Maintainer : ivan.perez@keera.co.uk
--
-- 'VectorSpace' instances for 'MSF's that produce vector spaces. This allows
-- you to use vector operators with 'MSF's that output vectors, for example,
-- you can write:
--
-- @
-- msf1 :: MSF Input (Double, Double) -- defined however you want
-- msf2 :: MSF Input (Double, Double) -- defined however you want
-- msf3 :: MSF Input (Double, Double)
-- msf3 = msf1 ^+^ msf2
-- @
--
-- instead of
--
-- @
-- msf3 = (msf1 &&& msf2) >>> arr (uncurry (^+^))
-- @
--
--
-- Instances are provided for the type class 'VectorSpace'.

-- Note: This module uses undecidable instances, because GHC does not know
-- enough to assert that it will be able to determine the type of 's' from the
-- type of 'v', because 'v' only appears under 'MSF' in the instance head and
-- it cannot determine what 'MSF' will do to 'v' and whether the type can be
-- resolved.
module Data.MonadicStreamFunction.Instances.VectorSpace where

-- External imports
import Control.Arrow    ((>>^))
import Data.VectorSpace (VectorSpace (..))

-- Internal imports
import Control.Arrow.Util              (constantly, elementwise2)
import Data.MonadicStreamFunction.Core (MSF)

-- | Vector-space instance for 'MSF's.
instance (Monad m, Eq s, Num s, VectorSpace v s, Floating (MSF m a s))
      => VectorSpace (MSF m a v) (MSF m a s)
  where
    zeroVector :: MSF m a v
zeroVector   = v -> MSF m a v
forall (a :: * -> * -> *) b c. Arrow a => b -> a c b
constantly v
forall v a. VectorSpace v a => v
zeroVector
    *^ :: MSF m a s -> MSF m a v -> MSF m a v
(*^)         = (s -> v -> v) -> MSF m a s -> MSF m a v -> MSF m a v
forall (a :: * -> * -> *) c d e b.
Arrow a =>
(c -> d -> e) -> a b c -> a b d -> a b e
elementwise2 s -> v -> v
forall v a. VectorSpace v a => a -> v -> v
(*^)
    ^/ :: MSF m a v -> MSF m a s -> MSF m a v
(^/)         = (v -> s -> v) -> MSF m a v -> MSF m a s -> MSF m a v
forall (a :: * -> * -> *) c d e b.
Arrow a =>
(c -> d -> e) -> a b c -> a b d -> a b e
elementwise2 v -> s -> v
forall v a. VectorSpace v a => v -> a -> v
(^/)
    ^+^ :: MSF m a v -> MSF m a v -> MSF m a v
(^+^)        = (v -> v -> v) -> MSF m a v -> MSF m a v -> MSF m a v
forall (a :: * -> * -> *) c d e b.
Arrow a =>
(c -> d -> e) -> a b c -> a b d -> a b e
elementwise2 v -> v -> v
forall v a. VectorSpace v a => v -> v -> v
(^+^)
    ^-^ :: MSF m a v -> MSF m a v -> MSF m a v
(^-^)        = (v -> v -> v) -> MSF m a v -> MSF m a v -> MSF m a v
forall (a :: * -> * -> *) c d e b.
Arrow a =>
(c -> d -> e) -> a b c -> a b d -> a b e
elementwise2 v -> v -> v
forall v a. VectorSpace v a => v -> v -> v
(^-^)
    negateVector :: MSF m a v -> MSF m a v
negateVector = (MSF m a v -> (v -> v) -> MSF m a v
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ v -> v
forall v a. VectorSpace v a => v -> v
negateVector)
    dot :: MSF m a v -> MSF m a v -> MSF m a s
dot          = (v -> v -> s) -> MSF m a v -> MSF m a v -> MSF m a s
forall (a :: * -> * -> *) c d e b.
Arrow a =>
(c -> d -> e) -> a b c -> a b d -> a b e
elementwise2 v -> v -> s
forall v a. VectorSpace v a => v -> v -> a
dot
    normalize :: MSF m a v -> MSF m a v
normalize MSF m a v
v  = (v -> s -> v) -> MSF m a v -> MSF m a s -> MSF m a v
forall (a :: * -> * -> *) c d e b.
Arrow a =>
(c -> d -> e) -> a b c -> a b d -> a b e
elementwise2 v -> s -> v
forall {a} {v}. (Eq a, Num a, VectorSpace v a) => v -> a -> v
f MSF m a v
v (MSF m a v -> MSF m a s
forall v a. VectorSpace v a => v -> a
norm MSF m a v
v)
      where
        f :: v -> a -> v
f v
v' a
nv'
          | a
nv' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0  = v
v' v -> a -> v
forall v a. VectorSpace v a => v -> a -> v
^/ a
nv'
          | Bool
otherwise = [Char] -> v
forall a. HasCallStack => [Char] -> a
error [Char]
"normalize: zero vector"