Fuzzy cardinalities

fuzzySets.cabal

@@ -32,6 +32,7 @@ library
         Fuzzy.Sets.LSet
         Fuzzy.Sets.MembershipFunctions
         Fuzzy.Sets.Cardinality
+        Fuzzy.Sets.FuzzyCardinality
         Fuzzy.Sets.Properties
         Fuzzy.Control.Defuzzification
         Fuzzy.Relations.LRelation
@@ -56,6 +57,7 @@ library
         FlexibleContexts
         FlexibleInstances
         FunctionalDependencies
+
 
 
 test-suite test
@@ -74,6 +76,7 @@ test-suite test
         UnitIntervalStructuresTest
         Utils.Utils
         Fuzzy.Sets.LSetTest
+        Fuzzy.Sets.FuzzyCardinalityTest
         Fuzzy.Sets.MembershipFunctionsTest
         Fuzzy.Sets.PropertiesTest
         Fuzzy.Relations.LRelationTest

src/Fuzzy/Sets/Cardinality.hs

@@ -8,11 +8,14 @@ module Fuzzy.Sets.Cardinality(
     sigmoidModifier,
     identityModifier,
     subDiagonalModifier,
-    alphaCutModifier
-) where 
+    alphaCutModifier,
+    ralescuS
+) where
 
 import Lattices.ResiduatedLattice
 import Fuzzy.Sets.LSet
+import FuzzySet
+import Data.List
 
 
 {- | Most commonly used way to tell the size of a fuzzy set.
@@ -31,7 +34,7 @@ For fuzzy set a |A| = Σ A(u) for all u ∈ U
 -}
 sigmaCount :: (FuzzySet set a l) => set -> Double
 sigmaCount set = sum [realToFrac (f x) | x <- universe set]
-    where f = member set 
+    where f = member set
 
 
 {- | Similar to 'sigmaCount', but applies a modifier function `c` to each membership value before summing.
@@ -62,10 +65,10 @@ Only membership values greater or equal than the threshold are summed.
 0.0
 -}
 thresholdSigmaCount :: (FuzzySet set a l) => l -> set -> Double
-thresholdSigmaCount threshold set = 
+thresholdSigmaCount threshold set =
     sum [realToFrac (f x) | x <- universe set, f x >= threshold]
     where f = member set
-    
+
 
 {- | Normalized sigma count is like the standard sigma count, but the value is normalized to be in the interval [0,1].
 
@@ -97,7 +100,7 @@ The parameters `p`, `r`, and `threshold` control the behavior of the modifier.
 -}
 modifierFunction :: (ResiduatedLattice l) => Double -> Double -> Double -> (l -> l)
 modifierFunction p r threshold a
-    | realToFrac a < threshold = mkLattice $ threshold ** (1 - p) * (realToFrac a ** p)
+    | realToFrac a < threshold  = mkLattice $ threshold ** (1 - p) * (realToFrac a ** p)
     | realToFrac a >= threshold = mkLattice $ 1 - (1 - threshold) ** (1 - r) * (1 - realToFrac a) ** r
 
 
@@ -159,11 +162,19 @@ threshold to 'bot' and values above the threshold to 'top'.
 1.0
 -}
 alphaCutModifier :: (ResiduatedLattice l) => Double -> (l -> l)
-alphaCutModifier threshold a 
+alphaCutModifier threshold a
     | realToFrac a <= threshold = bot
-    | realToFrac a > threshold = top
+    | realToFrac a > threshold  = top
 
 {- $modifier functions 
 Modifier functions give us a way to shift sigma count in case where needed. 
 Common solution for problem of accumulation of large number of small values. 
--}
+-}
+
+
+ralescuS :: (FuzzySet set a l) => set -> Int
+ralescuS set
+    | 0.5 `elem` degs = length [deg | deg <- degs, deg > 0.5] + 1
+    | otherwise       = length [deg | deg <- degs, deg > 0.5]
+    where
+        degs = 1 : sort (truthDegrees set) ++ [0]

src/Fuzzy/Sets/FuzzyCardinality.hs

@@ -0,0 +1,45 @@
+module Fuzzy.Sets.FuzzyCardinality(
+    fgCount,
+    feCount,
+    flCount,
+    ralescuF,
+    bracket
+) where
+
+import FuzzySet
+import Lattices.ResiduatedLattice
+import Fuzzy.Sets.LSet (toList)
+import Data.List (sort, sortBy)
+
+
+bracket :: (FuzzySet set a l) => Int -> set -> l
+bracket k set
+    | null alphas = 0
+    | otherwise   = maximum alphas
+    where
+        alphas = [alpha | alpha <- truthDegrees set, length (alphaCut alpha set) >= k]
+
+
+fgCount :: (FuzzySet set a l, FuzzySet countSet Int l) => set -> countSet
+fgCount set = mkFuzzySet f universeCounts
+    where
+        universeCounts = [0 .. universeCardinality set]
+        f k            = if k == 0 then 1 else bracket k set
+
+
+flCount :: (FuzzySet set a l, FuzzySet countSet Int l) => set -> countSet
+flCount set = mkFuzzySet f universeCounts
+    where
+        universeCounts = [0 .. universeCardinality set]
+        f k            = negation $ bracket (k + 1) set
+
+
+feCount :: (FuzzySet set a l, FuzzySet countSet Int l) => set -> countSet
+feCount set  = intersection (flCount set) (fgCount set)
+
+ralescuF :: (FuzzySet set a l, FuzzySet countSet Int l) => set -> countSet
+ralescuF set = mkFuzzySet f universeCounts
+    where
+        universeCounts = [0 .. universeCardinality set]
+        f k  = (degs !! k) /\ negation (degs !! (k + 1))
+        degs = 1 : sortBy (flip compare) (truthDegrees set) ++ [0]

src/Main.hs

@@ -0,0 +1,12 @@
+module Main where
+
+import Fuzzy.Sets.LSet
+import Fuzzy.Sets.FuzzyCardinality
+import Lattices.UnitIntervalStructures.Lukasiewicz (UILukasiewicz(UILukasiewicz))
+
+main :: IO ()
+main = do 
+    let set = fromList [("a", 0.1), ("b", 0.2), ("c", 0.1), ("d", 0.5), ("e", 0.7), ("f", 0.2), ("g", 0.4)] :: LSet String UILukasiewicz
+        --count = fgCount set :: LSet String UILukasiewicz
+        b = bracket 1 set
+    print b

test/Fuzzy/Sets/CardinalityTest.hs

@@ -0,0 +1,90 @@
+module Fuzzy.Sets.CardinalityTest (
+    cardinalityTests
+) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Fuzzy.Sets.LSet
+import Fuzzy.Sets.Cardinality
+import Lattices.UnitIntervalStructures.Lukasiewicz
+import Lattices.ResiduatedLattice
+import Utils.Utils
+
+
+cardinalityTests :: TestTree
+cardinalityTests = testGroup "Cardinality Tests" [
+    testCase "ralescuS numeric count" testRalescuS,
+    testCase "sigmaCount for set and empty" testSigmaCount,
+    testCase "thresholdSigmaCount behavior" testThresholdSigmaCount,
+    testCase "normalizedSigmaCount behavior" testNormalizedSigmaCount,
+    testCase "sigmaCountMod behavior" testSigmaCountMod,
+    testCase "modifierFunction and derived modifiers" testModifierFunctions,
+    testCase "alphaCutModifier boundary behavior" testAlphaCutModifier
+    ]
+
+
+whereSet :: LSet String UILukasiewicz
+whereSet = fromList [("a", 0.1), ("b", 0.2), ("c", 0.1), ("d", 0.5), ("e", 0.7), ("f", 0.2), ("g", 0.4)]
+
+
+testRalescuS :: Assertion
+testRalescuS =
+    assertEqual "ralescuS should count degrees > 0.5 plus boundary if equals 0.5"
+        3
+        (ralescuS whereSet)
+
+
+testSigmaCount :: Assertion
+testSigmaCount = do
+    let set = fromList [("x", 0.2), ("y", 0.7), ("z", 0.5)] :: LSet String UILukasiewicz
+        emptySet = mkEmptySet :: LSet Int UILukasiewicz
+    assertApproxEqual "sigmaCount from standard set" (sigmaCount set) 1.4
+    assertApproxEqual "sigmaCount empty set" (sigmaCount emptySet) 0.0
+
+
+testThresholdSigmaCount :: Assertion
+testThresholdSigmaCount = do
+    let set = fromList [("x", 0.2), ("y", 0.7), ("z", 0.5)] :: LSet String UILukasiewicz
+    assertApproxEqual "thresholdSigmaCount 0.5 should include 0.5 and 0.7" (thresholdSigmaCount 0.5 set) 1.2
+    assertApproxEqual "thresholdSigmaCount 0.8 should yield 0" (thresholdSigmaCount 0.8 set) 0.0
+
+
+testNormalizedSigmaCount :: Assertion
+testNormalizedSigmaCount = do
+    let set = fromList [("x", 0.2), ("y", 0.7), ("z", 0.5)] :: LSet String UILukasiewicz
+        result = fromLukasiewiczUnitInterval $ normalizedSigmaCount set
+    assertApproxEqual "normalizedSigmaCount should be sigmaCount / universe size" result (1.4 / 3)
+
+
+testSigmaCountMod :: Assertion
+testSigmaCountMod = do
+    let set = fromList [("x", 0.2), ("y", 0.7), ("z", 0.5)] :: LSet String UILukasiewicz
+    assertApproxEqual "sigmaCountMod identity equals sigmaCount" (sigmaCountMod identityModifier set) 1.4
+    assertApproxEqual "sigmaCountMod sigmoid 2 (threshold 1)" (sigmaCountMod (sigmoidModifier 2 1.0) set) 0.78
+
+
+testModifierFunctions :: Assertion
+testModifierFunctions = do
+    let mf = modifierFunction 2 2 0.5 :: UILukasiewicz -> UILukasiewicz
+    assertApproxEqual "modifierFunction below threshold" (fromLukasiewiczUnitInterval $ mf 0.3) 0.18
+    assertApproxEqual "modifierFunction above threshold" (fromLukasiewiczUnitInterval $ mf 0.7) 0.82
+
+    let sm = sigmoidModifier 2 0.5 :: UILukasiewicz -> UILukasiewicz
+    assertApproxEqual "sigmoidModifier below threshold" (fromLukasiewiczUnitInterval $ sm 0.3) 0.18
+    assertApproxEqual "sigmoidModifier above threshold" (fromLukasiewiczUnitInterval $ sm 0.7) 0.82
+
+    let im = identityModifier :: UILukasiewicz -> UILukasiewicz
+    assertApproxEqual "identityModifier preserve small" (fromLukasiewiczUnitInterval $ im 0.3) 0.3
+    assertApproxEqual "identityModifier preserve large" (fromLukasiewiczUnitInterval $ im 0.7) 0.7
+
+    let sd = subDiagonalModifier 2 :: UILukasiewicz -> UILukasiewicz
+    assertApproxEqual "subDiagonalModifier 2 for 0.3" (fromLukasiewiczUnitInterval $ sd 0.3) 0.09
+    assertApproxEqual "subDiagonalModifier 2 for 0.7" (fromLukasiewiczUnitInterval $ sd 0.7) 0.49
+
+
+testAlphaCutModifier :: Assertion
+testAlphaCutModifier = do
+    let ac = alphaCutModifier 0.5 :: UILukasiewicz -> UILukasiewicz
+    assertApproxEqual "alphaCutModifier below threshold" (fromLukasiewiczUnitInterval $ ac 0.3) 0.0
+    assertApproxEqual "alphaCutModifier at threshold" (fromLukasiewiczUnitInterval $ ac 0.5) 0.0
+    assertApproxEqual "alphaCutModifier above threshold" (fromLukasiewiczUnitInterval $ ac 0.7) 1.0

test/Fuzzy/Sets/FuzzyCardinalityTest.hs

@@ -0,0 +1,78 @@
+module Fuzzy.Sets.FuzzyCardinalityTest (
+    fuzzyCardinalityTests
+) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Fuzzy.Sets.LSet
+import Fuzzy.Sets.FuzzyCardinality
+import Lattices.UnitIntervalStructures.Lukasiewicz
+import Lattices.ResiduatedLattice
+import Utils.Utils
+
+fuzzyCardinalityTests :: TestTree
+fuzzyCardinalityTests = testGroup "Fuzzy Cardinality Tests" [
+    testCase "bracket identifies max alpha for given k" testBracket,
+    testCase "fgCount maps counts to maximal alpha" testFgCount,
+    testCase "flCount maps counts to minimal alpha" testFlCount,
+    testCase "feCount maps counts to intersection" testFeCount,
+    testCase "ralescuF returns fuzzy count" testRalescuF
+    ]
+
+whereSet :: LSet String UILukasiewicz
+whereSet = fromList [("a", 0.1), ("b", 0.2), ("c", 0.1), ("d", 0.5), ("e", 0.7), ("f", 0.2), ("g", 0.4)]
+
+
+testBracket :: Assertion
+testBracket =
+    assertApproxEqual "bracket 1 should be 0.7"
+        (fromLukasiewiczUnitInterval $ bracket 1 whereSet)
+        0.7
+
+
+testFgCount :: Assertion
+testFgCount = do
+    let c = fgCount whereSet :: LSet Int UILukasiewicz
+        expected = [(0,1),(1,0.7),(2,0.5),(3,0.4),(4,0.2),(5,0.2),(6,0.1),(7,0.1)]
+        actual = [(k, fromLukasiewiczUnitInterval v) | (k,v) <- toList c]
+        pairs = zip expected actual
+    mapM_ (\(e,a) -> do
+            assertEqual "fgCount key" (fst e) (fst a)
+            assertApproxEqual "fgCount value" (snd a) (snd e)
+        ) pairs
+
+
+testFlCount :: Assertion
+testFlCount = do
+    let c = flCount whereSet :: LSet Int UILukasiewicz
+        expected = [(0,0.3),(1,0.5),(2,0.6),(3,0.8),(4,0.8),(5,0.9),(6,0.9),(7,1.0)]
+        actual = [(k, fromLukasiewiczUnitInterval v) | (k,v) <- toList c]
+        pairs = zip expected actual
+    mapM_ (\(e,a) -> do
+            assertEqual "flCount key" (fst e) (fst a)
+            assertApproxEqual "flCount value" (snd a) (snd e)
+        ) pairs
+
+
+testFeCount :: Assertion
+testFeCount = do
+    let c = feCount whereSet :: LSet Int UILukasiewicz
+        expected = [(0,0.3),(1,0.5),(2,0.5),(3,0.4),(4,0.2),(5,0.2),(6,0.1),(7,0.1)]
+        actual = [(k, fromLukasiewiczUnitInterval v) | (k,v) <- toList c]
+        pairs = zip expected actual
+    mapM_ (\(e,a) -> do
+            assertEqual "feCount key" (fst e) (fst a)
+            assertApproxEqual "feCount value" (snd a) (snd e)
+        ) pairs
+
+
+testRalescuF :: Assertion
+testRalescuF = do
+    let c = ralescuF whereSet :: LSet Int UILukasiewicz
+        expected = [(0,0.3),(1,0.5),(2,0.5),(3,0.4),(4,0.2),(5,0.2),(6,0.1),(7,0.1)]
+        actual = [(k, fromLukasiewiczUnitInterval v) | (k,v) <- toList c]
+        pairs = zip expected actual
+    mapM_ (\(e,a) -> do
+            assertEqual "ralescuF key" (fst e) (fst a)
+            assertApproxEqual "ralescuF value" (snd a) (snd e)
+        ) pairs

test/Tests.hs

@@ -5,7 +5,8 @@ import Lattices.ResiduatedLattice
 import Lattices.UnitInterval
 import UnitIntervalStructuresTest
 import Fuzzy.Sets.LSetTest 
-import Fuzzy.Sets.MembershipFunctionsTest
+import Fuzzy.Sets.FuzzyCardinalityTest
+import Fuzzy.Sets.CardinalityTest
 import Fuzzy.Sets.PropertiesTest 
 import Fuzzy.Sets.MembershipFunctionsTest
 import Fuzzy.Relations.LRelationTest
@@ -19,9 +20,11 @@ main = defaultMain $ testGroup "All Tests" [
     lukasiewiczTests,
     productTests,
     lsetTests,
+    fuzzyCardinalityTests,
     membershipFunctionsTests,
     propertiesTests,
     lrelationTests,
     relPropertiesTests,
-    defuzzificationTests
+    defuzzificationTests,
+    cardinalityTests
     ]