{- | This module contains various compositions of binary 'LRelations'.
we provide natural language description of meaning of each type of composition 
on simple example with two relations R (x , y) - patient x has symptom y 
and S (y, z) - y is a symptom of z.
-}
module Fuzzy.Relations.RelationComposition (
    circlet,
    subproduct,
    superproduct,
    square,
) where

import Fuzzy.Relations.LRelation
import Lattices.ResiduatedLattice
import Utils.Utils

-- | R 'circlet' S (x, z) - Truth degree to which there is symptom y,

-- such that patient x has symptom y and y is a symptom of disease z

circlet :: (Eq a,ResiduatedLattice l) =>  LRelation a l -> LRelation a l -> LRelation a l
circlet :: forall a l.
(Eq a, ResiduatedLattice l) =>
LRelation a l -> LRelation a l -> LRelation a l
circlet (LRelation (a, a) -> l
r [(a, a)]
u) (LRelation (a, a) -> l
s [(a, a)]
_ ) = forall a l. ((a, a) -> l) -> [(a, a)] -> LRelation a l
LRelation (a, a) -> l
composition [(a, a)]
u
    where composition :: (a, a) -> l
composition (a
x, a
z) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall l. BoundedLattice l => l -> l -> l
(\/) forall l. BoundedLattice l => l
bot [(a, a) -> l
r (a
x, a
y) forall l. ResiduatedLattice l => l -> l -> l
`tnorm` (a, a) -> l
s (a
y, a
z) | a
y <- [a]
universe]
          universe :: [a]
universe = forall a. Eq a => [(a, a)] -> [a]
universeToList [(a, a)]
u

-- | R 'subproduct' S (x, z) - truth degree to which it is true that 

-- if patient x has symptom y than y is symptom of z

subproduct :: (Eq a,ResiduatedLattice l) => LRelation a l -> LRelation a l -> LRelation a l
subproduct :: forall a l.
(Eq a, ResiduatedLattice l) =>
LRelation a l -> LRelation a l -> LRelation a l
subproduct (LRelation (a, a) -> l
r [(a, a)]
u) (LRelation (a, a) -> l
s [(a, a)]
_) = forall a l. ((a, a) -> l) -> [(a, a)] -> LRelation a l
LRelation (a, a) -> l
composition [(a, a)]
u
    where composition :: (a, a) -> l
composition (a
x, a
z) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall l. BoundedLattice l => l -> l -> l
(/\) forall l. BoundedLattice l => l
top [(a, a) -> l
r (a
x, a
y) forall l. ResiduatedLattice l => l -> l -> l
--> (a, a) -> l
s (a
y, a
z) | a
y <- [a]
universe]
          universe :: [a]
universe = forall a. Eq a => [(a, a)] -> [a]
universeToList [(a, a)]
u
        
-- | R 'superproduct' S (x, z) - truth degree to which it is true that 

-- patient x has all symptoms of z

superproduct :: (Eq a,ResiduatedLattice l) => LRelation a l -> LRelation a l -> LRelation a l
superproduct :: forall a l.
(Eq a, ResiduatedLattice l) =>
LRelation a l -> LRelation a l -> LRelation a l
superproduct (LRelation (a, a) -> l
r [(a, a)]
u) (LRelation (a, a) -> l
s [(a, a)]
_) = forall a l. ((a, a) -> l) -> [(a, a)] -> LRelation a l
LRelation (a, a) -> l
composition [(a, a)]
u
    where composition :: (a, a) -> l
composition (a
x, a
z) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall l. BoundedLattice l => l -> l -> l
(/\) forall l. BoundedLattice l => l
bot [(a, a) -> l
r (a
x, a
y) forall l. ResiduatedLattice l => l -> l -> l
<-- (a, a) -> l
s (a
y, a
z) | a
y <- [a]
universe]
          eq :: a -> a -> l
eq a
x a
y = (a, a) -> l
r (a
x, a
y) forall l. ResiduatedLattice l => l -> l -> l
<--> (a, a) -> l
s (a
x, a
y)
          universe :: [a]
universe = forall a. Eq a => [(a, a)] -> [a]
universeToList [(a, a)]
u


-- | R 'square' S (x, z) - truth degree to which it is true that patient x has exactly the symptoms of z

square :: (Eq a, ResiduatedLattice l) => LRelation a l -> LRelation a l -> LRelation a l
square :: forall a l.
(Eq a, ResiduatedLattice l) =>
LRelation a l -> LRelation a l -> LRelation a l
square (LRelation (a, a) -> l
r [(a, a)]
u) (LRelation (a, a) -> l
s [(a, a)]
_) = forall a l. ((a, a) -> l) -> [(a, a)] -> LRelation a l
LRelation (a, a) -> l
composition [(a, a)]
u
    where composition :: (a, a) -> l
composition (a
x, a
z) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall l. BoundedLattice l => l -> l -> l
(/\) forall l. BoundedLattice l => l
bot [(a, a) -> l
r (a
x, a
y) forall l. ResiduatedLattice l => l -> l -> l
<--> (a, a) -> l
s (a
y, a
z) | a
y <- [a]
universe]
          universe :: [a]
universe = forall a. Eq a => [(a, a)] -> [a]
universeToList [(a, a)]
u