{-# 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 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 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 -- prop> preimage (^2) 25 [1..5] == [5] 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 -- prop> add godel1 (i, L.bottom) == godel1 -- prop> add goguen1 (i, L.bottom) == goguen1 -- prop> add lukas1 (i, L.bottom) == lukas1 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 -- prop> support godel1 == [1, 2] -- prop> support goguen1 == [1, 2] -- prop> support lukas1 == [1, 2] 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 -- prop> mu godel1 1 == Godel 0.2 -- prop> mu godel1 10 == L.bottom -- prop> mu goguen1 1 == Goguen 0.2 -- prop> mu goguen1 10 == L.bottom -- prop> mu lukas1 1 == Lukas 0.2 -- prop> mu lukas1 10 == L.bottom 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 -- prop> core (fromList [(-1, Godel 0.5), (0, Godel 0.8), (1, Godel 1.0), (2, Godel 0.4)]) == [1] -- prop> core (fromList [(-1, Goguen 0.5), (0, Goguen 0.8), (1, Goguen 1.0), (2, Goguen 0.4)]) == [1] -- prop> core (fromList [(-1, Lukas 0.5), (0, Lukas 0.8), (1, Lukas 1.0), (2, Lukas 0.4)]) == [1] 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 -- prop> alphaCut (fromList [(-1, Godel 0.5), (0, Godel 0.8), (1, Godel 1.0), (2, Godel 0.4)]) (Godel 0.5) == [-1, 0, 1] -- prop> alphaCut (fromList [(-1, Goguen 0.5), (0, Goguen 0.8), (1, Goguen 1.0), (2, Goguen 0.4)]) (Goguen 0.5) == [-1, 0, 1] -- prop> alphaCut (fromList [(-1, Lukas 0.5), (0, Lukas 0.8), (1, Lukas 1.0), (2, Lukas 0.4)]) (Lukas 0.5) == [-1, 0, 1] 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 -- prop> fromList [(1, Godel 0.2)] == add empty (1, Godel 0.2) -- prop> fromList [(1, Goguen 0.2)] == add empty (1, Goguen 0.2) -- prop> fromList [(1, Lukas 0.2)] == add empty (1, Lukas 0.2) 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 -- prop> map1 (*2) godel1 == fromList [(1, Godel 0.4), (2, Godel 1.0)] -- prop> map1 (*2) goguen1 == fromList [(1, Goguen 0.4), (2, Goguen 1.0)] -- prop> map1 (*2) lukas1 == fromList [(1, Lukas 0.4), (2, Lukas 1.0)] 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 -- prop> map2 (+) godel1 godel2 == fromList [(1, Godel 0.2), (2, Godel 0.7), (3, Godel 0.2)] -- prop> map2 (+) goguen1 goguen2 == fromList [(1, Goguen 0.2), (2, Goguen 0.7), (3, Goguen 0.2)] -- prop> map2 (+) lukas1 lukas2 == fromList [(1, Lukas 0.2), (2, Lukas 0.7), (3, Lukas 0.2)] 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 -- prop> union godel1 godel2 == fromList [(1, Godel 0.2), (2, Godel 0.5), (3, Godel 0.2)] -- prop> union goguen1 goguen2 == fromList [(1, Goguen 0.2), (2, Goguen 0.6), (3, Goguen 0.2)] -- prop> union lukas1 lukas2 == fromList [(1, Lukas 0.2), (2, Lukas 0.7), (3, Lukas 0.2)] 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 -- prop> intersection godel1 godel2 == fromList [(2, Godel 0.2)] -- prop> intersection goguen1 goguen2 == fromList [(2, Goguen 0.1)] -- prop> intersection lukas1 lukas2 == empty 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 -- prop> complement godel1 == fromList [(1, Godel 0.8), (2, Godel 0.5)] -- prop> complement goguen1 == fromList [(1, Goguen 0.8), (2, Goguen 0.5)] -- prop> complement lukas1 == fromList [(1, Lukas 0.8), (2, Lukas 0.5)] 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 -- prop> algebraicSum godel1 godel2 == fromList [(1, Godel 0.2), (2, Godel 0.7), (3, Godel 0.2)] -- prop> algebraicSum goguen1 goguen2 == fromList [(1, Goguen 0.2), (2, Goguen 0.7), (3, Goguen 0.2)] -- prop> algebraicSum lukas1 lukas2 == fromList [(1, Lukas 0.2), (2, Lukas 0.7), (3, Lukas 0.2)] 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 -- prop> algebraicProduct godel1 godel2 == fromList [(2, Godel 0.1)] -- prop> algebraicProduct goguen1 goguen2 == fromList [(2, Goguen 0.1)] -- prop> algebraicProduct lukas1 lukas2 == fromList [(2, Lukas 0.1)] 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 -- prop> generalizedProduct (+) godel1 godel2 == fromList [((1, 2), Godel 0.4), ((1, 3), Godel 0.4), ((2, 2), Godel 0.7), ((2, 3), Godel 0.7)] -- prop> generalizedProduct (+) goguen1 goguen2 == fromList [((1, 2), Goguen 0.4), ((1, 3), Goguen 0.4), ((2, 2), Goguen 0.7), ((2, 3), Goguen 0.7)] -- prop> generalizedProduct (+) lukas1 lukas2 == fromList [((1, 2), Lukas 0.4), ((1, 3), Lukas 0.4), ((2, 2), Lukas 0.7), ((2, 3), Lukas 0.7)] 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 -- prop> fmap (^2) (fromList [(-1, Godel 0.5), (0, Godel 0.8), (1, Godel 1.0), (2, Godel 0.4)]) == fromList [(0, Godel 0.8), (1, Godel 1.0), (4, Godel 0.4)] -- prop> fmap (^2) (fromList [(-1, Goguen 0.5), (0, Goguen 0.8), (1, Goguen 1.0), (2, Goguen 0.4)]) == fromList [(0, Goguen 0.8), (1, Goguen 1.0), (4, Goguen 0.4)] -- prop> fmap (^2) (fromList [(-1, Lukas 0.5), (0, Lukas 0.8), (1, Lukas 1.0), (2, Lukas 0.4)]) == fromList [(0, Lukas 0.8), (1, Lukas 1.0), (4, Lukas 0.4)] 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)]