Sets.hs

module Huzzy.Base.Sets where

newtype MF a = MF (a -> Double)
type MF' a = a -> Double

type FuzOp a = a -> a -> a

class Fuzzy a where
    (?&&) :: a -> a -> a
    (?||) :: a -> a -> a
    fnot  :: a -> a

instance Fuzzy Double where
    (?&&)  = max
    (?||)  = min
    fnot x = 1 - x

instance (Fuzzy b) => Fuzzy (a -> b) where
    f ?&& g      = \x -> f x ?&& g x
    f ?|| g      = \x -> f x ?|| g x
    fnot f       = fnot (\x -> f x)

instance Fuzzy (MF a) where
    (MF f) ?&& (MF g) = MF (f ?&& g)
    (MF f) ?|| (MF g) = MF (f ?|| g)
    fnot (MF f)       = MF (fnot f)

instance (Fuzzy a, Fuzzy b) => Fuzzy (a, b) where
  (a, b) ?&& (c, d) = (a ?&& c, b ?&& d)
  (a ,b) ?|| (c, d) = (a ?|| c, b ?|| d)
  fnot (a, b) = (fnot a, fnot b)

class FSet a where
  type Value a
  type Support a
  type Returned a
  support :: a -> Support a
  hedge   :: Double -> a -> a
  is      :: Value a -> a -> Returned a
{-
class FSet a b c d | a -> b, a -> c, a -> d where
  support :: a -> [c]
  hedge   :: Double -> a -> a
  is      :: b -> a -> d
-}

tNo :: Fuzzy a => FuzOp a -> a -> a -> a
tNo op = op

tCo :: (Num a, Fuzzy a) => FuzOp a -> a -> a -> a
tCo tNo a b = (-) 1 $ tNo (1 - a) (1 - b)

tGodel :: (Fuzzy a, Ord a) => FuzOp a
tGodel = min

tProd :: (Fuzzy a, Num a) => FuzOp a
tProd = (*)

tLuk :: (Fuzzy a, Num a, Ord a) => FuzOp a
tLuk a b = max 0 (a + b - 1)

tDras :: (Fuzzy a, Eq a, Num a) => FuzOp a
tDras a b | a == 1 = b
          | b == 1 = a
          | otherwise = 0

tNilMin :: (Fuzzy a, Eq a, Num a, Ord a) => FuzOp a
tNilMin a b | a + b > 1 = min a b
            | otherwise = 0

tHam :: (Fuzzy a, Eq a, Num a, Fractional a) => FuzOp a
tHam a b | a == b && b == 0 = 0
         | otherwise        = a*b/a+b-a*b

support' :: [a] -> MF' a -> [a]
support' xs f = filter (\x -> f x > 0) xs

hedge' :: Double -> MF' a -> MF' a
hedge' p f x | f x == 0 = 0
            | otherwise = f x ** p

approximate' :: Double -> Double -> [Double] -> MF' Double
approximate' fuzziness n dom = tri' a b c
  where hw = fuzziness * (ub' dom - lb' dom)
        a = (n - hw)
        b = (n+hw)
        c = b-((b-a)*0.5)

ub', lb' :: Ord a => [a] -> a
ub' = maximum
lb' = maximum

very', extremely', somewhat', slightly' :: MF' a -> MF' a
very'      = hedge' 2
extremely' = hedge' 3
somewhat'  = hedge' 0.5
slightly'  = hedge' (1/3)

discrete :: Eq a => [(a, Double)] -> MF a
discrete vs = MF (\x -> discrete' vs x)

discrete' :: Eq a => [(a, Double)] -> MF' a
discrete' vs x = case lookup x vs of
                  Just t -> t
                  Nothing -> 0

singleton :: Double -> MF a
singleton d = MF (\x -> singleton' d x)

singleton' :: Double -> MF' a
singleton' d x = d

up :: Double -> Double -> MF Double
up a b = MF (\x -> up' a b x)

up' :: Double -> Double -> MF' Double
up' a b x
  | x < a = 0
  | x < b = (x - a) / (b - a)
  | otherwise = 1

tri :: Double -> Double -> Double -> MF Double
tri a b c = MF (\x -> tri' a b c x)

tri' :: Double -> Double -> Double -> MF' Double
tri' a b c x | x <= a = 0
             | a <= x && x <= b = (x-a)/(b-a)
             | b <= x && x <= c = (c-x)/(c-b)
             | c <= x = 0

trap :: Double -> Double -> Double -> Double -> MF Double
trap a b c d = MF (\x -> trap' a b c d x)

trap' :: Double -> Double -> Double -> Double -> MF' Double
trap' a b c d x | x <= a || d <= x = 0
                | a <= x && x <= b = (x-a)/(b-a)
                | b <= x && x <= c = 1
                | c <= x && x <= d = (d-x)/(d-c)
                | otherwise = 0

gaus :: Double -> Double -> MF Double
gaus sig c = MF (\x -> gaus' sig c x)

gaus' :: Double -> Double -> MF' Double
gaus' sig c x = let e = exp 1 in e**((-0.5*(x-c/sig))**2)

bell :: Double -> Double -> Double -> MF Double
bell a b c = MF (\x -> bell' a b c x)

bell' :: Double -> Double -> Double -> MF' Double
bell' a b c x = 1/(1+abs ((x-c/a)**2*b))

sig :: Double -> Double -> MF Double
sig a c = MF (\x -> sig' a c x)

sig' :: Double -> Double -> MF' Double
sig' a c x = 1/(1+exp(-a*(x-c)))

-- Probably shit

cyl' :: Double -> Double -> MF' Double
cyl' a b x | sqrt (a**2 + b**2) <= x = 1
          | sqrt (a**2 + b**2) > x  = 0