FuzzySet.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | If X is a collection of objects denoted generically by x, then a fuzzy set F(A) in X is a set of ordered pairs.
-- Each of them consists of an element x and a membership function which maps x to the membership space M.
module Algebra.LFST.FuzzySet
( FuzzySet (..)
, preimage
, empty
, add
, support
, mu
, core
, alphaCut
, fromList
, map1
, map2
, union
, intersection
, complement
, algebraicSum
, algebraicProduct
, generalizedProduct
, ExoFunctor (..)
  ) where

import Prelude hiding (fmap)
import GHC.Exts (Constraint)
import qualified Algebra.Lattice as L
import qualified Data.List       as List
import qualified Data.Map        as Map
import qualified Data.Maybe      as Maybe ()

-- $setup
-- >>> import Algebra.LFST.Membership
-- >>> let godel1 = fromList [(1, Godel 0.2), (2, Godel 0.5)]
-- >>> let godel2 = fromList [(2, Godel 0.2), (3, Godel 0.2)]
-- >>> let goguen1 = fromList [(1, Goguen 0.2), (2, Goguen 0.5)]
-- >>> let goguen2 = fromList [(2, Goguen 0.2), (3, Goguen 0.2)]
-- >>> let lukas1 = fromList [(1, Lukas 0.2), (2, Lukas 0.5)]
-- >>> let lukas2 = fromList [(2, Lukas 0.2), (3, Lukas 0.2)]

-- | Returns the preimage of the given set in input
preimage :: (Eq i, Eq j) => (i -> j) ->  j -> [i] ->  [i]
preimage f y xs = [x | x <- xs, f x == y]

-- | FuzzySet type definition
newtype FuzzySet m i = FS (Map.Map i m) deriving (Eq, Ord)

instance (Ord i, L.BoundedLattice m, Show i, Show m) => Show (FuzzySet m i) where
  show (FS fs) = "FuzzySet {" ++  List.intercalate "," [show p | p <- Map.assocs fs] ++ "}"

-- | Returns an empty fuzzy set
empty :: (Ord i, L.BoundedLattice m) => FuzzySet m i
empty = FS Map.empty

-- | Inserts a new pair (i, m) to the fuzzy set
add :: (Ord i, Eq m, L.BoundedLattice m) => FuzzySet m i -> (i, m) -> FuzzySet m i
add (FS fs) (i, m) = if m == L.bottom then FS fs else FS (Map.insert i m fs)

-- | Returns the fuzzy set's support
support :: (Ord i, L.BoundedLattice m) => FuzzySet m i -> [i]
support (FS fs) = Map.keys fs

-- | Returns the element i's membership
-- if i belongs to the support returns its membership, otherwise returns bottom lattice value
mu :: (Ord i, L.BoundedLattice m) => FuzzySet m i -> i -> m
mu (FS fs) i = case result of
  Nothing -> L.bottom
  (Just m) -> m
  where result = Map.lookup i fs

-- | Returns the crisp subset of given fuzzy set consisting of all elements with membership equals to one
core :: (Ord i, Eq m, L.BoundedLattice m) => FuzzySet m i -> [i]
core fs = preimage (mu fs) L.top (support fs)

-- | Returns those elements whose memberships are greater or equal than the given alpha
alphaCut :: (Ord i, Ord m, L.BoundedLattice m) => FuzzySet m i -> m -> [i]
alphaCut fs alpha = [i | i <- support fs, mu fs i >= alpha]

-- | Builds a fuzzy set from a list of pairs
fromList :: (Ord i, Eq m, L.BoundedLattice m) => [(i, m)] -> FuzzySet m i
fromList = foldl add empty

-- | Applies a unary function to the specified fuzzy set
map1 :: (Ord i, Eq m, L.BoundedLattice m) => (m -> m) -> FuzzySet m i -> FuzzySet m i
map1 f fs = fromList [(i, f (mu fs i)) | i <- support fs]

-- | Applies a binary function to the two specified fuzzy sets
map2 :: (Ord i, Eq m, L.BoundedLattice m) => (m -> m -> m) -> FuzzySet m i -> FuzzySet m i -> FuzzySet m i
map2 f fs1 fs2 = fromList [(i, f (mu fs1 i) (mu fs2 i))| i <- union_support]
  where union_support = support fs1 `List.union` support fs2

-- | Returns the union between the two specified fuzzy sets
union :: (Ord i, Eq m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i -> FuzzySet m i
union = map2 (L.\/)

-- | Returns the intersection between the two specified fuzzy sets
intersection :: (Ord i, Eq m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i -> FuzzySet m i
intersection = map2 (L./\)

-- | Returns the complement of the specified fuzzy set
complement :: (Ord i, Num m, Eq m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i
complement fs = fromList [(x, L.top - mu fs x) | x <- support fs]

-- | Returns the algebraic sum between the two specified fuzzy sets
algebraicSum :: (Ord i, Eq m, Num m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i -> FuzzySet m i
algebraicSum = map2 (+)

-- | Returns the algebraic product between the two specified fuzzy sets
algebraicProduct :: (Ord i, Eq m, Num m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i -> FuzzySet m i
algebraicProduct = map2 (*)

-- | Returns the cartesian product between two fuzzy sets using the specified function
generalizedProduct :: (Ord i, Ord j, Eq m, L.BoundedLattice m) => (m -> m -> m) -> FuzzySet m i -> FuzzySet m j -> FuzzySet m (i, j)
generalizedProduct f fs1 fs2 = fromList [((x1, x2), f (mu fs1 x1) (mu fs2 x2) )| x1 <- support fs1, x2 <- support fs2]

-- | Defines a mapping between sub-categories preserving morphisms
class ExoFunctor f i where
  type SubCatConstraintI f i :: Constraint
  type SubCatConstraintI f i = ()
  type SubCatConstraintJ f j :: Constraint
  type SubCatConstraintJ f j = ()

  fmap :: (SubCatConstraintI f i, SubCatConstraintJ f j) => (i -> j) -> f i -> f j

-- | Defines a functor for the FuzzySet type which allows to implement the Extension principle
instance (L.BoundedLattice m, Eq m) => ExoFunctor (FuzzySet m)  i where
   type SubCatConstraintI (FuzzySet m) i  = Ord i
   type SubCatConstraintJ (FuzzySet m) j  = Ord j

   fmap f fs = fromList [(f x, mu_y (f x)) | x <- support fs]
     where mu_y y = L.joins1 [ mu fs a | a <- preimage f y (support fs)]