diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/huzzy.cabal b/huzzy.cabal new file mode 100644 --- /dev/null +++ b/huzzy.cabal @@ -0,0 +1,63 @@ +-- Initial huzzy.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: huzzy +version: 0.1.0.0 +synopsis: Fuzzy logic library with support for Type-1, Interval type-2 and zSlices enabled type-2 fuzzy sets and systems. +description: + Library for creating fuzzy sets and systems. + There are known issues with overly precise values in Type-2 sets. + Incredibly alpha, please do not use this for controlling your shower. + + Huge thanks to Emilio Gallego for his work on ffuzz: http://www.cis.upenn.edu/~emilioga/software/ffuzz/. + Heavily inspired by http://journals.cambridge.org/action/displayAbstract?fromPage=online&aid=44203 + + +license: MIT +-- license-file: LICENSE +author: Joe Nash +maintainer: joe@jna.sh +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Huzzy.Base.Sets, + Huzzy.Base.Systems, + Huzzy.TypeOne.Sets, + Huzzy.TypeOne.Systems, + Huzzy.TypeTwo.ZSlices.Sets, + Huzzy.TypeTwo.ZSlices.Systems, + Huzzy.TypeTwo.Interval.Sets, + Huzzy.TypeTwo.Interval.Systems, + Huzzy.Analysis.Graph + + --other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8, + easyplot + + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: FunctionalDependencies, + MultiParamTypeClasses, + FlexibleInstances, + TypeFamilies + + +--executable +-- hs-source-dirs: some-other-folderl + +--test-suite tests +-- hs-source-dirs: test +-- main-is: test.hs +-- type: exitcode-stdio-1.0 +-- build-depends: base >= 4.7 && < 4.8, +-- tasty, +-- tasty-quickcheck, +-- tasty-hunit, +-- huzzy + +-- default-language: Haskell2010 diff --git a/src/Huzzy/Analysis/Graph.hs b/src/Huzzy/Analysis/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/Analysis/Graph.hs @@ -0,0 +1,10 @@ +module Huzzy.Analysis.Graph where + +import Graphics.EasyPlot +import Huzzy.Base.Sets +import Huzzy.TypeOne.Sets +import Huzzy.TypeTwo.Interval.Sets +import Huzzy.TypeTwo.ZSlices.Sets + +--plotContT1 :: [a] -> T1Set a -> IO Bool +--plotContT1 diff --git a/src/Huzzy/Base/Sets.hs b/src/Huzzy/Base/Sets.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/Base/Sets.hs @@ -0,0 +1,163 @@ +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 diff --git a/src/Huzzy/Base/Systems.hs b/src/Huzzy/Base/Systems.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/Base/Systems.hs @@ -0,0 +1,37 @@ +module Huzzy.Base.Systems where + +import Huzzy.Base.Sets + +newtype FRule a => RuleBase a = RB [a] + +class Fuzzy a => FRule a where + type Antecedent a + (=*>) :: Antecedent a -> a -> a + (=|>) :: Antecedent a -> a -> a + weight :: a -> Double -> a + +instance FRule Double where + type Antecedent Double = Double + (=*>) a b = a * b + (=|>) a b = a `min` b + weight a b = a * b + +instance FRule b => FRule (a -> b) where + type Antecedent (a -> b) = Antecedent b + (=*>) a b = \x -> a =*> b x + (=|>) a b = \x -> a =|> b x + weight a b = \x -> a x `weight` b + +instance FRule (MF a) where + type Antecedent (MF a) = Double + (=*>) a (MF f) = MF (\x -> a =*> f x) + (=|>) a (MF f) = MF (\x -> a =|> f x) + weight (MF f) b = MF (\x -> f x `weight` b) + +class FRule a => Defuzzifier a where + type Result a + centroid :: a -> Result a + + +aggregate :: FRule a => RuleBase a -> (a -> a -> a) -> a +aggregate (RB rules) agg = foldr1 agg rules diff --git a/src/Huzzy/TypeOne/Sets.hs b/src/Huzzy/TypeOne/Sets.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/TypeOne/Sets.hs @@ -0,0 +1,94 @@ +module Huzzy.TypeOne.Sets where + +import Data.List(sortBy, nub, elemIndex) +import Data.Maybe(fromJust) +import Huzzy.Base.Sets + +data T1Set a = T1S { mf :: MF a + , dom :: [a] + } + +instance Fuzzy (T1Set a) where + a ?&& b = a { mf = (mf a) ?&& (mf b)} + a ?|| b = a { mf = (mf a) ?|| (mf b)} + fnot a = a { mf = fnot (mf a)} + +instance FSet (T1Set a) where + type Value (T1Set a) = a + type Support (T1Set a) = [a] + type Returned (T1Set a) = Double + support s = filter (\x -> (x `is` s) > 0) d + where + d = dom s + + hedge p s = s {mf = MF (\x -> mf' x)} + where + (MF f) = mf s + mf' x | f x == 0 = 0 + | otherwise = f x ** p + x `is` s = f x + where + (MF f) = mf s +{- +instance FSet (T1Set a) a a Double where + support s = filter (\x -> (x `is` s) > 0) d + where + d = dom s + + hedge p s = s {mf = MF (\x -> mf' x)} + where + (MF f) = mf s + mf' x | f x == 0 = 0 + | otherwise = f x ** p + x `is` s = f x + where + (MF f) = mf s +-} + +-- Smart Constructors +-- continuous :: a -> a -> a -> MF a -> T1Set a + +contT1 :: (Num a, Enum a) => a -> a -> a -> MF a -> T1Set a +contT1 minB maxB res (MF mf) = case check of + True -> error "Truth values must be in the range [0..1]" + False -> T1S { mf = MF mf + , dom = domain + } + where + domain = [minB, minB+res .. maxB] + check = any (\x -> x > 1 || x < 0) (map mf domain) + +discT1 :: [a] -> MF a -> T1Set a +discT1 dom (MF mf) = case check of + True -> error "Truth values must be in the range [0..1]" + False -> T1S { mf = MF mf + , dom = dom + } + where + check = any (\x -> x > 1 || x < 0) (map mf dom) + +trustedCont :: (Num a, Enum a) => a -> a -> a -> MF a -> T1Set a +trustedCont minB maxB res mf = T1S { mf = mf + , dom = [minB, minB+res .. maxB] + } + +trustedDisc :: [a] -> MF a -> T1Set a +trustedDisc dom mf = T1S { mf = mf + , dom = dom + } + +unsafeMkT1 :: [a] -> MF a -> T1Set a +unsafeMkT1 = trustedDisc + +alpha :: Double -> T1Set a -> [a] +alpha d s = filter (\x -> f x >= d) (dom s) + where + (MF f) = mf s + +findCuts :: Ord a => T1Set a -> Double -> (a, a) +findCuts s d = (l, r) + where + as = alpha d s + l = maximum as + li = fromJust $ elemIndex l as + r = maximum (snd $ splitAt li as) diff --git a/src/Huzzy/TypeOne/Systems.hs b/src/Huzzy/TypeOne/Systems.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/TypeOne/Systems.hs @@ -0,0 +1,19 @@ +module Huzzy.TypeOne.Systems where + +import Huzzy.Base.Sets +import Huzzy.Base.Systems +import Huzzy.TypeOne.Sets + +instance FRule (T1Set a) where + type Antecedent (T1Set a) = Double + (=*>) a t1s = t1s { mf = a =*> (mf t1s)} + (=|>) a t1s = t1s { mf = a =|> (mf t1s)} + weight t1s b = t1s {mf = (mf t1s) `weight` b} + +instance Defuzzifier (T1Set Double) where + type Result (T1Set Double) = Double + centroid t1s = sum (zipWith (*) dom' fdom) / sum fdom + where + dom' = dom t1s + (MF f) = mf t1s + fdom = map f dom' diff --git a/src/Huzzy/TypeTwo/Interval/Sets.hs b/src/Huzzy/TypeTwo/Interval/Sets.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/TypeTwo/Interval/Sets.hs @@ -0,0 +1,97 @@ +module Huzzy.TypeTwo.Interval.Sets where + +import Huzzy.Base.Sets +import Huzzy.TypeOne.Sets + +data IT2Set a = IT2S { lmf :: MF a + , umf :: MF a + , idom :: [a] + } + +instance Fuzzy (IT2Set a) where + a ?&& b = a { lmf = lmf a ?&& lmf b, umf = umf a ?&& umf b} + a ?|| b = a { lmf = lmf a ?|| lmf b, umf = umf a ?|| umf b} + fnot a = a { lmf = fnot (lmf a), umf = fnot (umf a)} + +instance FSet (IT2Set a) where + type Value (IT2Set a) = a + type Support (IT2Set a) = [(a,a)] + type Returned (IT2Set a) = (Double, Double) + support s = filter (\(x,y) -> (fst $ xis x) > 0 || (snd $ xis y) > 0) d + where + xis = \x -> x `is` s + d = zip (idom s) (idom s) + + hedge p s = s { lmf = MF (\x -> lmf' x) + , umf = MF (\x -> umf' x) + } + where + (MF l) = lmf s + (MF u) = umf s + lmf' x | l x == 0 = 0 + | otherwise = l x ** p + umf' x | u x == 0 = 0 + | otherwise = u x ** p + x `is` s = (l x, u x) + where + (MF l) = lmf s + (MF u) = umf s + +{- +instance FSet (IT2Set a) a (a,a) (Double, Double) where + support s = filter (\(x,y) -> (fst $ xis x) > 0 || (snd $ xis y) > 0) d + where + xis = \x -> x `is` s + d = zip (idom s) (idom s) + + hedge p s = s { lmf = MF (\x -> lmf' x) + , umf = MF (\x -> umf' x) + } + where + (MF l) = lmf s + (MF u) = umf s + lmf' x | l x == 0 = 0 + | otherwise = l x ** p + umf' x | u x == 0 = 0 + | otherwise = u x ** p + x `is` s = (l x, u x) + where + (MF l) = lmf s + (MF u) = umf s +-} + +contIT2 :: (Num a, Enum a) => a -> a -> a -> MF a -> MF a -> IT2Set a +contIT2 minB maxB res (MF lmf) (MF umf) = case check of + True -> error "Truth values must be in the range [0..1]" + False -> case check' of + True -> error "Truth values must be in the range [0..1]" + False -> IT2S { lmf = MF lmf + , umf = MF umf + , idom = domain + } + where + domain = [minB, minB+res .. maxB] + check = any (\x -> x > 1 || x < 0) (map lmf domain) + check' = any (\x -> x > 1 || x < 0) (map umf domain) + + +discIT2 :: [a] -> MF a -> MF a -> IT2Set a +discIT2 dom (MF lmf) (MF umf) = case check of + True -> error "Truth values must be in the range [0..1]" + False -> case check' of + True -> error "Truth values must be in the range [0..1]" + False -> IT2S { lmf = MF lmf + , umf = MF umf + , idom = dom + } + where + check = any (\x -> x > 1 || x < 0) (map lmf dom) + check' = any (\x -> x > 1 || x < 0) (map umf dom) + +unsafeMkIT2 :: [a] -> MF a -> MF a -> IT2Set a +unsafeMkIT2 dom lmf umf = IT2S { lmf = lmf + , umf = umf + , idom = dom } + +cylExt :: Double -> Double -> IT2Set a +cylExt l u = unsafeMkIT2 [] (singleton l) (singleton u) diff --git a/src/Huzzy/TypeTwo/Interval/Systems.hs b/src/Huzzy/TypeTwo/Interval/Systems.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/TypeTwo/Interval/Systems.hs @@ -0,0 +1,115 @@ +module Huzzy.TypeTwo.Interval.Systems where + +import Data.List +import Huzzy.Base.Sets +import Huzzy.Base.Systems +import Huzzy.TypeTwo.Interval.Sets + +instance FRule (IT2Set a) where + type Antecedent (IT2Set a) = (Double, Double) + (=*>) (a,b) it2 = it2 { lmf = a =*> (lmf it2) + , umf = b =*> (umf it2) + } + (=|>) (a,b) it2 = it2 { lmf = a =|> (lmf it2) + , umf = b =|> (umf it2) + } + weight it2 b = it2 { lmf = (lmf it2) `weight` b + , umf = (umf it2) `weight` b + } + +instance Defuzzifier (IT2Set Double) where + type Result (IT2Set Double) = (Double, Double) + centroid its = (yl, yr) + where + (yl, yr, _, _) = km its + + +{- + +Karnik mendel haskell +todo dirty hack fix +-} + +km :: IT2Set Double -> ( Double -- yl + , Double -- yr + , Int -- k l + , Int -- k r + ) +km its = case findK 0 yI xs of + Nothing -> error "No k 1" + Just k -> revCompCheck yI k + where + lrsup = unzip $ support its + xs = getXS lrsup + (wsl, wsu) = getWS its xs + weightsI = getWeights (wsl, wsu) + yI = weightedSum xs weightsI + doLeft k' yi' = case findK k' yi' xs of + Nothing -> error ("No k 2, k:" ++ show k' ++ " yi:" ++ show yi' ) + Just k -> revCompCheck yi' k' + revCompCheck yi'' k' = case y' == yi'' of + True -> (y', yr, k', kr) + where + (yr, kr) = kmr its + False -> doLeft 0 y' + where + ws = lWeights wsl wsu k' + y' = weightedSum xs ws + +kmr :: IT2Set Double -> ( Double -- yr + , Int -- k r + ) +kmr its = case findK 0 yI xs of + Nothing -> error "no k 3" + Just k -> revCompCheck yI k + where + lrsup = unzip $ support its + xs = getXS lrsup + (wsl, wsu) = getWS its xs + weightsI = getWeights (wsl, wsu) + yI = weightedSum xs weightsI + doRight k' yi' = case findK k' yi' xs of + Nothing -> error "No k 4" + Just k -> revCompCheck yi' k' + revCompCheck yi'' k' = case y' == yi'' of + True -> (y', k') + False -> doRight 0 y' + where + ws = rWeights wsl wsu k' + y' = weightedSum xs ws + +getXS :: Ord a => ([a], [a]) -- Supports + -> [a] -- xs +getXS (ls, us) = sort $ nub $ ls ++ us + +getWS :: IT2Set a -- Input set + -> [a] -- xs + -> ([Double], [Double]) --x_ x^- +getWS its xs = unzip $ map (\x -> x `is` its) xs + +getWeights :: ([Double], [Double]) -- w_ w^- + -> [Double] -- w +getWeights (lws, uws) = zipWith (\l u -> (l+u)/2) lws uws + +weightedSum :: [Double] -> [Double] -> Double +weightedSum x w = sum (zipWith (*) x w) / sum w + +findK :: Int -> Double -> [Double] -> Maybe Int +findK k y xs = if k >= length xs then Nothing else + case (xs !! k) <= y && y <= (xs !! k+1) of + True -> Just k + False -> findK (k+1) y xs + +lWeights :: [Double] -> [Double] -> Int -> [Double] +lWeights lws uws k = r' ++ l' + where + (r',_) = splitAt k uws + (_,l') = splitAt k lws + + +rWeights :: [Double] -> [Double] -> Int -> [Double] +rWeights lws uws k = l' ++ r' + where + (l',_) = splitAt k lws + (_,r') = splitAt k uws + diff --git a/src/Huzzy/TypeTwo/ZSlices/Sets.hs b/src/Huzzy/TypeTwo/ZSlices/Sets.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/TypeTwo/ZSlices/Sets.hs @@ -0,0 +1,103 @@ +module Huzzy.TypeTwo.ZSlices.Sets where + +import Data.Function +import Data.List +import Huzzy.Base.Sets +import Huzzy.TypeOne.Sets +import Huzzy.TypeTwo.Interval.Sets + +data T2ZSet a = T2ZS { zLevels :: Int + , zSlices :: [IT2Set a] + , zdom :: [a] + } + +instance Fuzzy (T2ZSet a) where + a ?&& b = a { zLevels = zLevels a, zSlices = zipWith (?&&) (zSlices a) (zSlices b) } + a ?|| b = a { zLevels = zLevels a, zSlices = zipWith (?||) (zSlices a) (zSlices b) } + fnot a = a { zLevels = zLevels a, zSlices = map (fnot) (zSlices a) } + +instance FSet (T2ZSet a) where + type Value (T2ZSet a) = a + type Support (T2ZSet a) = [(a,a)] + type Returned (T2ZSet a) = MF Double + support s = support (head $ zSlices s) + hedge d s = s { zSlices = map (hedge d) (zSlices s)} + x `is` s = discrete disPairs + where + its = zSlices s + (ls, us) = unzip $ map (x`is`) its + zs = zLevelAxis (length its) + -- todo dirty hack to ensure max is returned + disPairs = sortBy (flip compare `on` snd ) $ zip ls zs ++ zip us zs + + +zLevelAxis :: Int -> [Double] +zLevelAxis n = 0 : (count step (n'-1)) + where + n' = fromIntegral $ n-1 + step = 1/n' + count s 0 = [s*n'] + count s z = (s*(n'-z)) : count s (z-1) + +contZT2 :: (Enum a, Num a) => a -> a -> a -> [IT2Set a] -> T2ZSet a +contZT2 minB maxB res its = case check of + True -> error "Truth values must be in the range [0..1]" + False -> case check' of + True -> error "Truth values must be in the range [0..1]" + False -> T2ZS { zLevels = length its + , zSlices = its + , zdom = domain + } + where + (MF lf, MF uf) = (lmf $ head its, umf $ head its) + domain = [minB, minB+res .. maxB] + check = any (\x -> x > 1 || x < 0) (map lf domain) + check' = any (\x -> x > 1 || x < 0) (map uf domain) + +discZT2 :: [a] -> [IT2Set a] -> T2ZSet a +discZT2 dom its = case check of + True -> error "Truth values must be in the range [0..1]" + False -> case check' of + True -> error "Truth values must be in the range [0..1]" + False -> T2ZS { zLevels = length its + , zSlices = its + , zdom = dom + } + where + (MF lf, MF uf) = (lmf $ head its, umf $ head its) + check = any (\x -> x > 1 || x < 0) (map lf dom) + check' = any (\x -> x > 1 || x < 0) (map uf dom) + +unsafeZT2 :: [a] -> [IT2Set a] -> T2ZSet a +unsafeZT2 dom its = T2ZS { zLevels = length its + , zSlices = its + , zdom = dom + } + +cylExtT2 :: T1Set Double -> Int -> T2ZSet Double +cylExtT2 s z = T2ZS { zLevels = z + , zSlices = map (\(l, r) -> cylExt l r) lsrs + , zdom = [] + } + where + zs = zLevelAxis z + lsrs = map (findCuts s) zs + +t2Tri :: (Double, Double) -> + (Double, Double) -> + (Double, Double) -> + Int -> T2ZSet Double +t2Tri (a,a') (b,b') (c,c') z = T2ZS { zLevels = z + , zSlices = base : rc (z-1) stepA stepC + , zdom = dom } + where + dom = [min a a' .. max c c'] + base = unsafeMkIT2 dom (tri a b c) (tri a' b' c') + stepA = ((a-a')/fromIntegral (z-1))/2 + stepC = ((c-c')/fromIntegral (z-1))/2 + rc 0 _ _ = [] + rc z sa sc = (unsafeMkIT2 + [min (a-sa) (a'-sa) .. max (c-sc) (c'-sc)] + (tri (a-sa) b (c-sc)) + ((tri (a'-sa) b' (c'-sc)))) + : (rc (z-1) (sa+stepA) (sc+stepC)) diff --git a/src/Huzzy/TypeTwo/ZSlices/Systems.hs b/src/Huzzy/TypeTwo/ZSlices/Systems.hs new file mode 100644 --- /dev/null +++ b/src/Huzzy/TypeTwo/ZSlices/Systems.hs @@ -0,0 +1,29 @@ +module Huzzy.TypeTwo.ZSlices.Systems where + +import Data.Function(on) +import Data.List(sortBy, nub) +import Huzzy.Base.Sets +import Huzzy.Base.Systems +import Huzzy.TypeOne.Sets +import Huzzy.TypeOne.Systems +import Huzzy.TypeTwo.Interval.Sets +import Huzzy.TypeTwo.Interval.Systems +import Huzzy.TypeTwo.ZSlices.Sets + + +instance FRule (T2ZSet Double) where + type Antecedent (T2ZSet Double) = T1Set Double + (=*>) t1 t2 = (cylExtT2 t1 (zLevels t2)) ?|| t2 + (=|>) t1 t2 = (cylExtT2 t1 (zLevels t2)) ?|| t2 + weight t2 x = t2 {zSlices = map (\it2 -> weight it2 x) (zSlices t2)} + +instance Defuzzifier (T2ZSet Double) where + type Result (T2ZSet Double) = T1Set Double + centroid t2s = unsafeMkT1 (ldom++rdom) $ discrete disPairs + where + its = zSlices t2s + (ldom, rdom) = unzip $ support (head its) + (ls, us) = unzip $ map centroid its + zs = zLevelAxis (length its) + -- todo dirty hack to ensure max is returned + disPairs = sortBy (flip compare `on` snd ) $ zip ls zs ++ zip us zs