Emping-0.3: src/Reduce.hs
module Reduce (isSub,f2Grp, redAll, ambOrg ) where
{- module: get the reduced normal form of a rule model
a fact is a list of attribute value pairs
a rule is a the same list of av pairs, interpreted with
init as antecedent and last as consequent (of course
reshuffled according to consequent attribute selection)
the reduction algorithm is implemented by redPos p n
redAll implements this on a group of rules, partitioned
by their consequent attribute. So redAll follows f2Grp!
-}
import Data.List (nub, (\\), nubBy, partition, delete )
-- some general purpose functions
isSub :: Eq a => [a] -> [a] -> Bool
isSub [] _ = True
isSub (x:xs) y | not (x `elem` y) = False
| otherwise = isSub xs y
isEq :: Eq a => [a] -> [a] -> Bool
isEq x y = isSub x y && isSub y x
-- minLs needs to take second value because of foldr in extrMin
minLs :: Eq a => [a] -> [a] -> [a]
minLs x y | x `isSub` y = x
| otherwise = y
-- partitions a list according to an equivalence relation
partitionBy :: (a -> a -> Bool) -> [a] -> [[a]]
partitionBy _ [] = []
partitionBy eq ls = x:(partitionBy eq y) where
(x,y) = partition ((head ls) `eq`) ls
-- A,B and C: the reduction algorithm in its three steps
-- A: formulate hypothesis from original rules (positive)
hypot :: Eq a => [[a]] -> [a]
hypot = nub . concat
-- B: falsify the hypothesis
-- 1. match with all the rules (negative)
match :: Eq a => [a] -> [[a]] -> [[a]]
match h = map (h \\)
-- B.2 falsification
-- count the occurrences of something in a list and
-- return the list without it (if it is an element)
delCount :: Eq a => a -> [a] -> (Int, [a])
delCount _ [] = (0,[])
delCount x (y:ys)
| x == y = (fst(delCount x ys) + 1,snd (delCount x ys))
| otherwise = (fst(delCount x ys), y:snd(delCount x ys))
-- return the elements of a list with their counts
elWCnt :: Eq a => [a] -> [(a, Int)]
elWCnt [] = []
elWCnt (x:xs) = (x, cnt) : elWCnt res where
cnt = fst (delCount x (x:xs))
res = snd (delCount x (x:xs))
-- sort the frequency list, most occurring first
freqSort :: Eq a => [(a,Int)] -> [(a,Int)]
freqSort [] = []
freqSort [x] = [x]
freqSort (x:xs) =
(freqSort high) ++ [x] ++ (freqSort low) where
high = [h | h <- xs, (snd h) >= (snd x)]
low = [l | l <- xs, (snd l) < (snd x)]
-- make the list from which the roots and root children
-- are built. (a is an av pair in Reduce, not needed)
mkavRtLs :: Eq a => [[a]] -> [a]
mkavRtLs = fst . unzip . freqSort . elWCnt . concat
-- delete an element with a property, if it is there, and
-- report its presence. Lists without that element unchanged.
findDel :: Eq a => (a -> Bool) -> [a] -> Bool -> ([a],Bool)
findDel _ [] s = ([],s)
findDel p (y:ys) s
| p y = (fst $ findDel p ys s, True)
| otherwise = (y:(fst $ findDel p ys s), snd $ findDel p ys s)
-- fst: list without element that satisfies p (may be [])
-- snd: True if there was such an element, else False
findDelPred :: Eq a => (a -> Bool) -> [a] -> ([a],Bool)
findDelPred p ls = findDel p ls False
-- from an av and an or-list, get the children or-list
-- and the or-list for the next av. There are 4 possibilities.
-- test a possible child or-list
chldsrc ::(Eq a, Eq b) => a -> [([(a,b)],Bool)] -> Maybe [[(a,b)]]
chldsrc att porls2
| porls2 == [] = Just [] -- will be leaf
| otherwise =
let porls3 = map fst porls2
chorls = map (findDelPred (\x -> att == fst x)) porls3 in
if ([],True) `elem` chorls -- or-list contradiction
then Nothing
else Just (map fst chorls)
-- test a possible next in a forest
tnextsrc :: (Eq a, Eq b) => [([(a,b)],Bool)] -> Maybe [[(a,b)]]
tnextsrc porls1 | porls1 == [] = Nothing
| otherwise = if ([],True) `elem` porls1
then Nothing -- contradiction
else Just (map fst porls1)
-- split an original or-list into children (fst) and next (snd)
splitOrls :: (Eq a, Eq b) => (a,b)-> [[(a,b)]] -> (Maybe [[(a,b)]],Maybe [[(a,b)]])
splitOrls av orls = (x,y) where
x = chldsrc (fst av) v
y = if (tnextsrc u) == Nothing
then Nothing
else Just (map fst imls)
(u,v) = partition snd imls
imls = map (findDelPred (av ==)) orls
-- changes here ----------------------------
-- make root list with children from sorted possibles
rootLs :: (Eq a, Eq b)=>[(a,b)]->[[(a,b)]]->[Maybe ((a,b),[[(a,b)]])]
rootLs _ [] = []
rootLs [] _ = error "Reduce rootLs: root source is []"
rootLs (x:xs) orls = tsrc:rootLs xs next where
tsrc = case pchld of
Nothing -> Nothing
Just chld -> Just (x,chld)
next = case pnext of
Nothing -> []
Just nxt -> nxt
(pchld, pnext) = splitOrls x orls
-- make root list with childsource from or list
makeRtChldLs :: (Eq a, Eq b) => [[(a,b)]] -> [Maybe ((a,b),[[(a,b)]])]
makeRtChldLs [] = error "Reduce makeRtChldLs: list is []"
makeRtChldLs orls = rootLs (mkavRtLs orls) orls
-- define a rose tree that can have empty branches
data Maytree a = Niets | Wel {avLabel::a, avChils :: Mayfor a}
deriving Eq
type Mayfor a = [Maytree a]
-- make a tree and forest from Maybe roots and source children
mkAVMTree :: (Eq a, Eq b) => Maybe ((a,b),[[(a,b)]]) -> Maytree (a,b)
mkAVMTree rtchls =
case rtchls of
Nothing -> Niets
Just (x,[]) -> Wel {avLabel = x, avChils = []}
Just (x, suborls) -> Wel {avLabel = x,
avChils = mkAVMFor suborls }
mkAVMFor:: (Eq a, Eq b) => [[(a,b)]] -> Mayfor (a,b)
mkAVMFor suborls = map mkAVMTree rtchls where
rtchls = makeRtChldLs suborls
-- get the branches of a Maytree
-- the empty lists are lost because of concatMap
brMayTree :: Maytree a -> [[a]]
brMayTree t = case t of
Niets -> []
(Wel x []) -> [[x]]
(Wel x for) -> map (x:) brls where
brls = concatMap brMayTree for
-- extract the smallest sublists from the orlist of andlists
extrMin :: Eq a => [[a]] -> [[a]]
extrMin ls = nubBy isEq [ getMinin x ls | x <-ls ]
where getMinin x y = foldr minLs x y
-- final transformation of an and-list of ors to or-list of ands
-- replaces the identically named function in Reduce in Emping 0.2
trAndOr :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]]
trAndOr orls =
extrMin (concatMap brMayTree for) where for = mkAVMFor orls
-- C: Verify the falsification result with the original positive rules
verify :: Eq a => [[a]] -> [[a]] -> [[a]]
verify flsd orig = [x | x <- flsd , x `isIn` orig ] where
isIn y ls = or (map (isSub y) ls)
-- A, B and C: reduce a list of positive original rules
-- Note: redPos takes antecedents only!
redPos :: (Eq a,Eq b) => [[(a,b)]] -> [[(a,b)]] -> [[(a,b)]]
redPos p n = verify (trAndOr (match (hypot p) n)) p
-------------------------------------------------------
-- facts to rules by putting consequent attribute last
shuf :: (Eq a, Eq b) => a -> [(a,b)] -> [(a,b)]
shuf at avls = (fst z) ++ (snd z) where
z = partition ((at /=) . fst) avls
f2rules :: (Eq a, Eq b) => a -> [[(a,b)]] -> [[(a,b)]]
f2rules at facls = map (shuf at) facls
-- group according to consequent attribute-values
f2Grp :: (Eq a, Eq b) => a -> [[(a,b)]] -> [[[(a,b)]]]
f2Grp at facls =
partitionBy (\x y -> (last x) == (last y)) ruls where
ruls = f2rules at facls
-- reduce one of a group of rules. Consequent is last in
-- each rule list..
redOne :: (Eq a, Eq b) => [[[(a,b)]]] -> [[(a,b)]] -> [[(a,b)]]
redOne grp rls = map (++ [cns]) (redPos p n) where
p = map init rls
n = map init (concat $ (delete rls grp))
cns = (last . head) rls
-- reduce a rule model for all attribute-value pairs
-- the consequents will be last in each AV-list
-- Note: facts are converted to grouped rules by f2rGrp!
redAll :: (Eq a,Eq b)=> [[[(a,b)]]] -> [[[(a,b)]]]
redAll rlgrp = map (redOne rlgrp) rlgrp
--------------------------------------------------------
-- find ambiguities in rule group
-- Note: == works because rows have same av order
ambOrg :: (Eq a, Eq b) => [[[(a,b)]]] -> [[[(a,b)]]]
ambOrg grp = filter (\x -> (length x) > 1) anteqs where
anteqs = partitionBy (\x y -> (init x) == (init y)) ols
ols = concat grp