{-# OPTIONS_GHC -fno-warn-orphans #-}
module Pandora.Paradigm.Primary.Linear.Vector where

import Pandora.Pattern.Category ((<--))
import Pandora.Pattern.Object.Semigroup (Semigroup ((+)))
import Pandora.Pattern.Object.Ringoid (Ringoid ((*)))
import Pandora.Pattern.Object.Monoid (Monoid (zero))
import Pandora.Pattern.Object.Quasiring (Quasiring (one))
import Pandora.Pattern.Object.Group (Group (invert))
import Pandora.Pattern.Object.Setoid (Setoid ((==)))
import Pandora.Paradigm.Algebraic.Product ((:*:) ((:*:)))
import Pandora.Paradigm.Structure.Ability.Monotonic (Monotonic (reduce))

data Vector r a where
	Scalar :: a -> Vector a a
	Vector :: a -> Vector r a -> Vector (a :*: r) a

instance Semigroup a => Semigroup (Vector a a) where
	~(Scalar a
x) + :: Vector a a -> Vector a a -> Vector a a
+ ~(Scalar a
y) = a -> Vector a a
forall a. a -> Vector a a
Scalar (a -> Vector a a) -> a -> Vector a a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
y

instance (Semigroup a, Semigroup r, Semigroup (a :*: r), Semigroup (Vector r a)) => Semigroup (Vector (a :*: r) a) where
	Vector a
x Vector r a
xs + :: Vector (a :*: r) a -> Vector (a :*: r) a -> Vector (a :*: r) a
+ Vector a
y Vector r a
ys = a -> Vector r a -> Vector (a :*: r) a
forall a r. a -> Vector r a -> Vector (a :*: r) a
Vector (a -> Vector r a -> Vector (a :*: r) a)
-> a -> Vector r a -> Vector (a :*: r) a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
y (Vector r a -> Vector (a :*: r) a)
-> Vector r a -> Vector (a :*: r) a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- Vector r a
xs Vector r a -> Vector r a -> Vector r a
forall a. Semigroup a => a -> a -> a
+ Vector r a
Vector r a
ys

instance Ringoid a => Ringoid (Vector a a) where
	~(Scalar a
x) * :: Vector a a -> Vector a a -> Vector a a
* ~(Scalar a
y) = a -> Vector a a
forall a. a -> Vector a a
Scalar (a -> Vector a a) -> a -> Vector a a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- a
x a -> a -> a
forall a. Ringoid a => a -> a -> a
* a
y

instance (Ringoid a, Ringoid r, Ringoid (a :*: r), Ringoid (Vector r a)) => Ringoid (Vector (a :*: r) a) where
	Vector a
x Vector r a
xs * :: Vector (a :*: r) a -> Vector (a :*: r) a -> Vector (a :*: r) a
* Vector a
y Vector r a
ys = a -> Vector r a -> Vector (a :*: r) a
forall a r. a -> Vector r a -> Vector (a :*: r) a
Vector (a -> Vector r a -> Vector (a :*: r) a)
-> a -> Vector r a -> Vector (a :*: r) a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- a
x a -> a -> a
forall a. Ringoid a => a -> a -> a
* a
y (Vector r a -> Vector (a :*: r) a)
-> Vector r a -> Vector (a :*: r) a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- Vector r a
xs Vector r a -> Vector r a -> Vector r a
forall a. Ringoid a => a -> a -> a
* Vector r a
Vector r a
ys

instance Monoid a => Monoid (Vector a a) where
	zero :: Vector a a
zero = a -> Vector a a
forall a. a -> Vector a a
Scalar a
forall a. Monoid a => a
zero

instance (Monoid a, Monoid r, Monoid (a :*: r), Monoid (Vector r a)) => Monoid (Vector (a :*: r) a) where
	zero :: Vector (a :*: r) a
zero = a -> Vector r a -> Vector (a :*: r) a
forall a r. a -> Vector r a -> Vector (a :*: r) a
Vector a
forall a. Monoid a => a
zero Vector r a
forall a. Monoid a => a
zero

instance Quasiring a => Quasiring (Vector a a) where
	one :: Vector a a
one = a -> Vector a a
forall a. a -> Vector a a
Scalar a
forall a. Quasiring a => a
one

instance (Quasiring a, Quasiring r, Quasiring (a :*: r), Quasiring (Vector r a)) => Quasiring (Vector (a :*: r) a) where
	one :: Vector (a :*: r) a
one = a -> Vector r a -> Vector (a :*: r) a
forall a r. a -> Vector r a -> Vector (a :*: r) a
Vector a
forall a. Quasiring a => a
one Vector r a
forall a. Quasiring a => a
one

instance Group a => Group (Vector a a) where
	invert :: Vector a a -> Vector a a
invert ~(Scalar a
x) = a -> Vector a a
forall a. a -> Vector a a
Scalar (a -> Vector a a) -> a -> Vector a a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- a -> a
forall a. Group a => a -> a
invert a
x

instance (Group a, Group r, Group (a :*: r), Group (Vector r a)) => Group (Vector (a :*: r) a) where
	invert :: Vector (a :*: r) a -> Vector (a :*: r) a
invert (Vector a
x Vector r a
xs) = a -> Vector r a -> Vector (a :*: r) a
forall a r. a -> Vector r a -> Vector (a :*: r) a
Vector (a -> Vector r a -> Vector (a :*: r) a)
-> a -> Vector r a -> Vector (a :*: r) a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- a -> a
forall a. Group a => a -> a
invert a
x (Vector r a -> Vector (a :*: r) a)
-> Vector r a -> Vector (a :*: r) a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- Vector r a -> Vector r a
forall a. Group a => a -> a
invert Vector r a
xs

instance Setoid a => Setoid (Vector a a) where
	~(Scalar a
x) == :: Vector a a -> Vector a a -> Boolean
== ~(Scalar a
y) = a
x a -> a -> Boolean
forall a. Setoid a => a -> a -> Boolean
== a
y

instance (Setoid a, Setoid (Vector r a)) => Setoid (Vector (a :*: r) a) where
	Vector a
x Vector r a
xs == :: Vector (a :*: r) a -> Vector (a :*: r) a -> Boolean
== Vector a
y Vector r a
ys = (a
x a -> a -> Boolean
forall a. Setoid a => a -> a -> Boolean
== a
y) Boolean -> Boolean -> Boolean
forall a. Ringoid a => a -> a -> a
* (Vector r a
xs Vector r a -> Vector r a -> Boolean
forall a. Setoid a => a -> a -> Boolean
== Vector r a
Vector r a
ys)

instance Monotonic a (Vector a a) where
	reduce :: (a -> r -> r) -> r -> Vector a a -> r
reduce a -> r -> r
f r
r ~(Scalar a
x) = a -> r -> r
f a
x r
r

instance Monotonic a (Vector r a) => Monotonic a (Vector (a :*: r) a) where
	reduce :: (a -> r -> r) -> r -> Vector (a :*: r) a -> r
reduce a -> r -> r
f r
r (Vector a
x Vector r a
xs) = (a -> r -> r) -> r -> Vector r a -> r
forall a e r. Monotonic a e => (a -> r -> r) -> r -> e -> r
reduce a -> r -> r
f (r -> Vector r a -> r) -> r -> Vector r a -> r
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- a -> r -> r
f a
x r
r (Vector r a -> r) -> Vector r a -> r
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- Vector r a
xs

class Vectorize a r where
	vectorize :: r -> Vector r a

instance Vectorize a a where
	vectorize :: a -> Vector a a
vectorize a
x = a -> Vector a a
forall a. a -> Vector a a
Scalar a
x

instance Vectorize a r => Vectorize a (a :*: r) where
	vectorize :: (a :*: r) -> Vector (a :*: r) a
vectorize (a
x :*: r
r) = a -> Vector r a -> Vector (a :*: r) a
forall a r. a -> Vector r a -> Vector (a :*: r) a
Vector a
x (Vector r a -> Vector (a :*: r) a)
-> Vector r a -> Vector (a :*: r) a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- r -> Vector r a
forall a r. Vectorize a r => r -> Vector r a
vectorize r
r