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 ()
preimage :: (Eq i, Eq j) => (i -> j) -> j -> [i] -> [i]
preimage f y xs = [x | x <- xs, f x == y]
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] ++ "}"
empty :: (Ord i, L.BoundedLattice m) => FuzzySet m i
empty = FS Map.empty
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)
support :: (Ord i, L.BoundedLattice m) => FuzzySet m i -> [i]
support (FS fs) = Map.keys fs
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
core :: (Ord i, Eq m, L.BoundedLattice m) => FuzzySet m i -> [i]
core fs = preimage (mu fs) L.top (support fs)
alphaCut :: (Ord i, Ord m, L.BoundedLattice m) => FuzzySet m i -> m -> [i]
alphaCut fs alpha = [i | i <- support fs, mu fs i >= alpha]
fromList :: (Ord i, Eq m, L.BoundedLattice m) => [(i, m)] -> FuzzySet m i
fromList = foldl add empty
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]
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
union :: (Ord i, Eq m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i -> FuzzySet m i
union = map2 (L.\/)
intersection :: (Ord i, Eq m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i -> FuzzySet m i
intersection = map2 (L./\)
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]
algebraicSum :: (Ord i, Eq m, Num m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i -> FuzzySet m i
algebraicSum = map2 (+)
algebraicProduct :: (Ord i, Eq m, Num m, L.BoundedLattice m) => FuzzySet m i -> FuzzySet m i -> FuzzySet m i
algebraicProduct = map2 (*)
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]
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
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)]