{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE TypeFamilies, TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DataKinds, RankNTypes #-}

-- |

-- Module      : OAlg.Data.Ornt

-- Description : homomorphisms to Oriantations. 

-- Copyright   : (c) Erich Gut

-- License     : BSD3

-- Maintainer  : zerich.gut@gmail.com

-- 

-- homomorphisms to 'Orientation'. 

module OAlg.Data.Ornt
  ( Ornt(..), orntAppl
  )
  where

import OAlg.Prelude

import OAlg.Structure.Oriented
import OAlg.Structure.Multiplicative
import OAlg.Structure.Fibred
import OAlg.Structure.FibredOriented
import OAlg.Structure.Additive
import OAlg.Structure.Distributive

import OAlg.Hom.Oriented
import OAlg.Hom.Multiplicative
import OAlg.Hom.Fibred
import OAlg.Hom.FibredOriented
import OAlg.Hom.Additive
import OAlg.Hom.Distributive

--------------------------------------------------------------------------------

-- Ornt -


-- | homomorphisms to 'Orientation'.

data Ornt s x y where
  Ornt    :: (Structure s m, Structure s (Orientation (Point m)))
          => Ornt s m (Orientation (Point m))
  OrntMap :: (Structure s (Orientation a), Structure s (Orientation b))
          => (a -> b) -> Ornt s (Orientation a) (Orientation b)

--------------------------------------------------------------------------------

-- Ornt - Hom -


instance Morphism (Ornt s) where
  type ObjectClass (Ornt s) = s
  homomorphous :: forall x y. Ornt s x y -> Homomorphous (ObjectClass (Ornt s)) x y
homomorphous Ornt s x y
Ornt        = Struct s x
forall s x. Structure s x => Struct s x
Struct Struct s x -> Struct s y -> Homomorphous s x y
forall s x y. Struct s x -> Struct s y -> Homomorphous s x y
:>: Struct s y
forall s x. Structure s x => Struct s x
Struct
  homomorphous (OrntMap a -> b
_) = Struct s x
forall s x. Structure s x => Struct s x
Struct Struct s x -> Struct s y -> Homomorphous s x y
forall s x y. Struct s x -> Struct s y -> Homomorphous s x y
:>: Struct s y
forall s x. Structure s x => Struct s x
Struct

instance TransformableTyp s => TransformableObjectClassTyp (Ornt s)

domOrt :: Transformable s Ort => Ornt s x y -> Struct Ort x
domOrt :: forall s x y. Transformable s Ort => Ornt s x y -> Struct Ort x
domOrt o :: Ornt s x y
o@Ornt s x y
Ornt        = Struct s x -> Struct Ort x
forall x. Struct s x -> Struct Ort x
forall s t x. Transformable s t => Struct s x -> Struct t x
tau (Struct s x -> Struct Ort x) -> Struct s x -> Struct Ort x
forall (h :: * -> * -> *) x y. Applicative h => h x y -> x -> y
$ Ornt s x y -> Struct (ObjectClass (Ornt s)) x
forall x y. Ornt s x y -> Struct (ObjectClass (Ornt s)) x
forall (m :: * -> * -> *) x y.
Morphism m =>
m x y -> Struct (ObjectClass m) x
domain Ornt s x y
o
domOrt o :: Ornt s x y
o@(OrntMap a -> b
_) = Struct s (Orientation a) -> Struct Ort x
Struct s (Orientation a) -> Struct Ort (Orientation a)
forall x. Struct s x -> Struct Ort x
forall s t x. Transformable s t => Struct s x -> Struct t x
tau (Struct s (Orientation a) -> Struct Ort x)
-> Struct s (Orientation a) -> Struct Ort x
forall (h :: * -> * -> *) x y. Applicative h => h x y -> x -> y
$ Ornt s x y -> Struct (ObjectClass (Ornt s)) x
forall x y. Ornt s x y -> Struct (ObjectClass (Ornt s)) x
forall (m :: * -> * -> *) x y.
Morphism m =>
m x y -> Struct (ObjectClass m) x
domain Ornt s x y
o

domFbrOrt :: Transformable s FbrOrt => Ornt s x y -> Struct FbrOrt x
domFbrOrt :: forall s x y.
Transformable s FbrOrt =>
Ornt s x y -> Struct FbrOrt x
domFbrOrt o :: Ornt s x y
o@Ornt s x y
Ornt        = Struct s x -> Struct FbrOrt x
forall x. Struct s x -> Struct FbrOrt x
forall s t x. Transformable s t => Struct s x -> Struct t x
tau (Struct s x -> Struct FbrOrt x) -> Struct s x -> Struct FbrOrt x
forall (h :: * -> * -> *) x y. Applicative h => h x y -> x -> y
$ Ornt s x y -> Struct (ObjectClass (Ornt s)) x
forall x y. Ornt s x y -> Struct (ObjectClass (Ornt s)) x
forall (m :: * -> * -> *) x y.
Morphism m =>
m x y -> Struct (ObjectClass m) x
domain Ornt s x y
o
domFbrOrt o :: Ornt s x y
o@(OrntMap a -> b
_) = Struct s (Orientation a) -> Struct FbrOrt x
Struct s (Orientation a) -> Struct FbrOrt (Orientation a)
forall x. Struct s x -> Struct FbrOrt x
forall s t x. Transformable s t => Struct s x -> Struct t x
tau (Struct s (Orientation a) -> Struct FbrOrt x)
-> Struct s (Orientation a) -> Struct FbrOrt x
forall (h :: * -> * -> *) x y. Applicative h => h x y -> x -> y
$ Ornt s x y -> Struct (ObjectClass (Ornt s)) x
forall x y. Ornt s x y -> Struct (ObjectClass (Ornt s)) x
forall (m :: * -> * -> *) x y.
Morphism m =>
m x y -> Struct (ObjectClass m) x
domain Ornt s x y
o

rngFbrOrt :: Transformable s FbrOrt => Ornt s x y -> Struct FbrOrt y
rngFbrOrt :: forall s x y.
Transformable s FbrOrt =>
Ornt s x y -> Struct FbrOrt y
rngFbrOrt o :: Ornt s x y
o@Ornt s x y
Ornt        = Struct s (Orientation (Point x)) -> Struct FbrOrt y
Struct s (Orientation (Point x))
-> Struct FbrOrt (Orientation (Point x))
forall x. Struct s x -> Struct FbrOrt x
forall s t x. Transformable s t => Struct s x -> Struct t x
tau (Struct s (Orientation (Point x)) -> Struct FbrOrt y)
-> Struct s (Orientation (Point x)) -> Struct FbrOrt y
forall (h :: * -> * -> *) x y. Applicative h => h x y -> x -> y
$ Ornt s x y -> Struct (ObjectClass (Ornt s)) y
forall x y. Ornt s x y -> Struct (ObjectClass (Ornt s)) y
forall (m :: * -> * -> *) x y.
Morphism m =>
m x y -> Struct (ObjectClass m) y
range Ornt s x y
o
rngFbrOrt o :: Ornt s x y
o@(OrntMap a -> b
_) = Struct s (Orientation b) -> Struct FbrOrt y
Struct s (Orientation b) -> Struct FbrOrt (Orientation b)
forall x. Struct s x -> Struct FbrOrt x
forall s t x. Transformable s t => Struct s x -> Struct t x
tau (Struct s (Orientation b) -> Struct FbrOrt y)
-> Struct s (Orientation b) -> Struct FbrOrt y
forall (h :: * -> * -> *) x y. Applicative h => h x y -> x -> y
$ Ornt s x y -> Struct (ObjectClass (Ornt s)) y
forall x y. Ornt s x y -> Struct (ObjectClass (Ornt s)) y
forall (m :: * -> * -> *) x y.
Morphism m =>
m x y -> Struct (ObjectClass m) y
range Ornt s x y
o

-- | applying an 'Ornt'.

orntAppl :: Transformable s Ort => Ornt s x y -> x -> y
orntAppl :: forall s x y. Transformable s Ort => Ornt s x y -> x -> y
orntAppl o :: Ornt s x y
o@Ornt s x y
Ornt x
m             = case Ornt s x y -> Struct Ort x
forall s x y. Transformable s Ort => Ornt s x y -> Struct Ort x
domOrt Ornt s x y
o of Struct Ort x
Struct -> x -> Point x
forall q. Oriented q => q -> Point q
start x
m Point x -> Point x -> Orientation (Point x)
forall p. p -> p -> Orientation p
:> x -> Point x
forall q. Oriented q => q -> Point q
end x
m
orntAppl (OrntMap a -> b
f) (a
s :> a
e) = a -> b
f a
s b -> b -> Orientation b
forall p. p -> p -> Orientation p
:> a -> b
f a
e

instance TransformableOrt s => ApplicativeG Id (Ornt s) (->) where
  amapG :: forall x y. Ornt s x y -> Id x -> Id y
amapG Ornt s x y
h (Id x
x) = y -> Id y
forall x. x -> Id x
Id y
y where y :: y
y = Ornt s x y -> x -> y
forall s x y. Transformable s Ort => Ornt s x y -> x -> y
orntAppl Ornt s x y
h x
x

instance ApplicativeG Pnt (Ornt s) (->) where
  amapG :: forall x y. Ornt s x y -> Pnt x -> Pnt y
amapG Ornt s x y
Ornt        (Pnt Point x
p) = Point y -> Pnt y
forall x. Point x -> Pnt x
Pnt Point x
Point y
p
  amapG (OrntMap a -> b
f) (Pnt Point x
p) = Point y -> Pnt y
forall x. Point x -> Pnt x
Pnt b
Point y
q where q :: b
q = a -> b
f a
Point x
p

instance Transformable s FbrOrt => ApplicativeG Rt (Ornt s) (->) where
  amapG :: forall x y. Ornt s x y -> Rt x -> Rt y
amapG Ornt s x y
h (Rt Root x
r) = case (Ornt s x y -> Struct FbrOrt x
forall s x y.
Transformable s FbrOrt =>
Ornt s x y -> Struct FbrOrt x
domFbrOrt Ornt s x y
h, Ornt s x y -> Struct FbrOrt y
forall s x y.
Transformable s FbrOrt =>
Ornt s x y -> Struct FbrOrt y
rngFbrOrt Ornt s x y
h) of (Struct FbrOrt x
Struct,Struct FbrOrt y
Struct) -> Root y -> Rt y
forall x. Root x -> Rt x
Rt Orientation (Point y)
Root y
s where s :: Orientation (Point y)
s = Ornt s x y -> Orientation (Point x) -> Orientation (Point y)
forall (h :: * -> * -> *) a b.
ApplicativePoint h =>
h a b -> Orientation (Point a) -> Orientation (Point b)
omap Ornt s x y
h Orientation (Point x)
Root x
r 
  

instance TransformableOrt s    => HomOriented (Ornt s) where
instance TransformableMlt s    => HomMultiplicative (Ornt s)
instance TransformableFbrOrt s => HomFibred (Ornt s)

instance (TransformableFbrOrt s, TransformableAdd s) => HomAdditive (Ornt s)

instance TransformableFbrOrt s => HomFibredOriented (Ornt s)

instance TransformableDst s => HomDistributive (Ornt s)