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

import Pandora.Pattern.Semigroupoid ((.))
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.Primary.Algebraic.Product ((:*:) ((:*:)))
import Pandora.Paradigm.Primary.Functor.Maybe (Maybe (Just, Nothing))
import Pandora.Paradigm.Primary.Transformer.Construction (Construction (Construct))
import Pandora.Paradigm.Schemes.TT (TT (TT))
import Pandora.Paradigm.Structure.Ability.Nonempty (Nonempty)
import Pandora.Paradigm.Structure.Ability.Monotonic (Monotonic (reduce))
import Pandora.Paradigm.Structure.Ability.Morphable (Morphable (Morphing, morphing), Morph (Into, Push), premorph, into, item)
import Pandora.Paradigm.Structure.Some.List (List)
import Pandora.Paradigm.Controlflow.Effect.Interpreted ((!))

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 :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
! 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 :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
! 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 :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
! 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

-- TODO: move these instances to somewhere else since they involve structures
instance Morphable (Into List) (Vector r) where
	type Morphing (Into List) (Vector r) = List
	morphing :: (<::>) (Tagged ('Into List)) (Vector r) a
-> Morphing ('Into List) (Vector r) a
morphing ((<::>) (Tagged ('Into List)) (Vector r) a -> Vector r a
forall k (mod :: k) (struct :: * -> *).
Morphable mod struct =>
(Tagged mod <::> struct) ~> struct
premorph -> Scalar r
x) = ((Maybe :. Construction Maybe) := r)
-> TT Covariant Covariant Maybe (Construction Maybe) r
forall k k k k (ct :: k) (ct' :: k) (t :: k -> *) (t' :: k -> k)
       (a :: k).
((t :. t') := a) -> TT ct ct' t t' a
TT (((Maybe :. Construction Maybe) := r)
 -> TT Covariant Covariant Maybe (Construction Maybe) r)
-> (Construction Maybe r -> (Maybe :. Construction Maybe) := r)
-> Construction Maybe r
-> TT Covariant Covariant Maybe (Construction Maybe) r
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. Construction Maybe r -> (Maybe :. Construction Maybe) := r
forall a. a -> Maybe a
Just (Construction Maybe r
 -> TT Covariant Covariant Maybe (Construction Maybe) r)
-> Construction Maybe r
-> TT Covariant Covariant Maybe (Construction Maybe) r
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
! r -> ((Maybe :. Construction Maybe) := r) -> Construction Maybe r
forall (t :: * -> *) a.
a -> ((t :. Construction t) := a) -> Construction t a
Construct r
x (Maybe :. Construction Maybe) := r
forall a. Maybe a
Nothing
	morphing ((<::>) (Tagged ('Into List)) (Vector r) a -> Vector r a
forall k (mod :: k) (struct :: * -> *).
Morphable mod struct =>
(Tagged mod <::> struct) ~> struct
premorph -> Vector a
x Vector r a
xs) = a :=:=> List
forall k (mod :: k) (struct :: * -> *) a.
Morphed mod struct ((Identity <:.:> struct) := (->)) =>
a :=:=> struct
item @Push a
x (TT Covariant Covariant Maybe (Construction Maybe) a
 -> TT Covariant Covariant Maybe (Construction Maybe) a)
-> TT Covariant Covariant Maybe (Construction Maybe) a
-> TT Covariant Covariant Maybe (Construction Maybe) a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
! Vector r a -> Morphing ('Into List) (Vector r) a
forall a (mod :: a) (struct :: * -> *).
Morphable ('Into mod) struct =>
struct ~> Morphing ('Into mod) struct
into @List Vector r a
xs

instance Morphable (Into (Construction Maybe)) (Vector r) where
	type Morphing (Into (Construction Maybe)) (Vector r) = Construction Maybe
	morphing :: (<::>) (Tagged ('Into (Construction Maybe))) (Vector r) a
-> Morphing ('Into (Construction Maybe)) (Vector r) a
morphing ((<::>) (Tagged ('Into (Construction Maybe))) (Vector r) a
-> Vector r a
forall k (mod :: k) (struct :: * -> *).
Morphable mod struct =>
(Tagged mod <::> struct) ~> struct
premorph -> Scalar r
x) = r -> ((Maybe :. Construction Maybe) := r) -> Construction Maybe r
forall (t :: * -> *) a.
a -> ((t :. Construction t) := a) -> Construction t a
Construct r
x (Maybe :. Construction Maybe) := r
forall a. Maybe a
Nothing
	morphing ((<::>) (Tagged ('Into (Construction Maybe))) (Vector r) a
-> Vector r a
forall k (mod :: k) (struct :: * -> *).
Morphable mod struct =>
(Tagged mod <::> struct) ~> struct
premorph -> Vector a
x Vector r a
xs) = a :=:=> Construction Maybe
forall k (mod :: k) (struct :: * -> *) a.
Morphed mod struct ((Identity <:.:> struct) := (->)) =>
a :=:=> struct
item @Push a
x (Construction Maybe a -> Construction Maybe a)
-> Construction Maybe a -> Construction Maybe a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
! Vector r a -> Morphing ('Into (Nonempty List)) (Vector r) a
forall a (mod :: a) (struct :: * -> *).
Morphable ('Into mod) struct =>
struct ~> Morphing ('Into mod) struct
into @(Nonempty List) 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 :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
! r -> Vector r a
forall a r. Vectorize a r => r -> Vector r a
vectorize r
r