{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Fuzzy.Sets.LSet(
    LSet(LSet),
    FuzzySet(member, universe),
    fromPairs,
    fromFunction,
    toPairs,
    mkEmptySet,
    mkSingletonSet,
    mkUniversalSet
) where

import Lattices.UnitInterval
import Lattices.ResiduatedLattice
import FuzzySet
import Data.Maybe(fromMaybe)

-- | Fuzzy set A is a mapping from universe set U to the set of Truth values L

-- A: U -> L this function is called 'membership' function

data (ResiduatedLattice l) => LSet a l = LSet
    {
    -- | membership function 

     forall a l. ResiduatedLattice l => LSet a l -> a -> l
membership :: a -> l
    -- | universe set

    , forall a l. ResiduatedLattice l => LSet a l -> [a]
universe :: ![a]
    }


instance (Eq a, Show a, Show l, ResiduatedLattice l) => Show (LSet a l) where
    show :: LSet a l -> String
    show :: LSet a l -> String
show LSet a l
set = String
"FuzzySet { " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall l a. (ResiduatedLattice l, Eq a) => LSet a l -> [(a, l)]
toPairs LSet a l
set) forall a. [a] -> [a] -> [a]
++ String
" }"


instance (ResiduatedLattice l, Eq a) => FuzzySet (LSet a l) a l where
    member :: LSet a l -> a -> l
    member :: LSet a l -> a -> l
member (LSet a -> l
f [a]
_) = a -> l
f 
    universe :: LSet a l -> [a]
    universe :: LSet a l -> [a]
universe (LSet a -> l
_ [a]
u) = [a]
u
    mkFuzzySet :: (a -> l) -> [a] -> LSet a l
    mkFuzzySet :: (a -> l) -> [a] -> LSet a l
mkFuzzySet = forall a l. (a -> l) -> [a] -> LSet a l
LSet


-- | Construct fuzzy set from list of pairs

fromPairs :: (ResiduatedLattice l, Eq a) => [(a, l)] -> LSet a l
fromPairs :: forall l a. (ResiduatedLattice l, Eq a) => [(a, l)] -> LSet a l
fromPairs [(a, l)]
xs = forall a l. (a -> l) -> [a] -> LSet a l
LSet a -> l
f [a]
u
    where
        f :: a -> l
f a
x = forall a. a -> Maybe a -> a
fromMaybe forall l. BoundedLattice l => l
bot (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
x [(a, l)]
xs)
        u :: [a]
u = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, l)]
xs


{- | Construct a fuzzy set from a membership function and a universe set

==== __Examples__

>>> let f x = if x == 1 then 0.8 else 0.3
>>> let set = fromFunction f [1, 2, 3] :: LSet Int UILukasiewicz
>>> toPairs set
[(1,0.8),(2,0.3),(3,0.3)]
-}
fromFunction :: (ResiduatedLattice l) => (a -> l) -> [a] -> LSet a l
fromFunction :: forall l a. ResiduatedLattice l => (a -> l) -> [a] -> LSet a l
fromFunction = forall a l. (a -> l) -> [a] -> LSet a l
LSet


-- | Convert fuzzy set to list of pairs 

toPairs :: (ResiduatedLattice l, Eq a) => LSet a l -> [(a, l)]
toPairs :: forall l a. (ResiduatedLattice l, Eq a) => LSet a l -> [(a, l)]
toPairs (LSet a -> l
f [a]
universe) = [(a
u, a -> l
f a
u) | a
u <- [a]
universe]


{- | Construct an empty fuzzy set

==== __Examples__

>>> let emptySet = mkEmptySet :: LSet Int UILukasiewicz
>>> toPairs emptySet
[]
-}
mkEmptySet :: (ResiduatedLattice l) => LSet a l
mkEmptySet :: forall l a. ResiduatedLattice l => LSet a l
mkEmptySet = forall a l. (a -> l) -> [a] -> LSet a l
LSet (forall a b. a -> b -> a
const forall l. BoundedLattice l => l
bot) []

{- | Construct a singleton fuzzy set

==== __Examples__

>>> let singletonSet = mkSingletonSet [1, 2, 3] (2, 0.8) :: LSet Int UILukasiewicz
>>> toPairs singletonSet
[(1,0.0),(2,0.8),(3,0.0)]
-}
mkSingletonSet :: (ResiduatedLattice l, Eq a) => [a] -> (a, l) -> LSet a l
mkSingletonSet :: forall l a.
(ResiduatedLattice l, Eq a) =>
[a] -> (a, l) -> LSet a l
mkSingletonSet [a]
u (a
x, l
l) = forall a l. (a -> l) -> [a] -> LSet a l
LSet a -> l
f [a]
u
    where
        f :: a -> l
f a
y
            | a
y forall a. Eq a => a -> a -> Bool
== a
x = l
l
            | Bool
otherwise = forall l. BoundedLattice l => l
bot


{- | Construct a universal fuzzy set

==== __Examples__

>>> let universalSet = mkUniversalSet [1, 2, 3] :: LSet Int UILukasiewicz
>>> toPairs universalSet
[(1,1.0),(2,1.0),(3,1.0)]
-}
mkUniversalSet :: (ResiduatedLattice l, Eq a) => [a] -> LSet a l
mkUniversalSet :: forall l a. (ResiduatedLattice l, Eq a) => [a] -> LSet a l
mkUniversalSet = forall a l. (a -> l) -> [a] -> LSet a l
LSet (forall a b. a -> b -> a
const forall l. BoundedLattice l => l
top)