Emping-0.5: src/Reduce.hs
{- | Emping 0.5 (provisional)
Module Reduce transforms a list of facts into a partition of rules for each value of a selected attribute, and returns all shortest rules (reduced normal form).
The reduction takes a coded fact list, which may have been checked for doubles (see module Codec). The original rules can be checked first for ambiguities. Ambiguous rules have the same antecedent, but a different consequent.
Fri 04 Apr 2008 07:18:23 PM CEST
-}
module Reduce ( getAmbiguous, facts2Rules, reduceAll )where
import Data.List ( nub, (\\), partition, nubBy, delete )
import Aux
-- A,B and C: the reduction algorithm in its three steps
-- A: formulate hypothesis from original antecedents of a consequent
-- | returns a disjunction of all antecedent av's
hypot :: [Ant] -> [AVp]
hypot = nub . concat
-- B: falsify the hypothesis
-- B1. match with all the antecedents of other than the consequent
-- | the reduction as a conjunction of disjunctions
fsfmatch :: [AVp] -> [[AVp]] -> [[AVp]]
fsfmatch h = map (h \\)
-- B2. transform conjunction of disjunctions into disjunction of conjunctions
-- | count the occurrences in a list and return the list without it (if it is present)
delCount :: AVp -> [AVp] -> (Int, [AVp])
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 :: [AVp] -> [(AVp, 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 :: [(AVp,Int)] -> [(AVp,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.
mkavRtLs :: [[AVp]] -> [AVp]
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 :: (AVp -> Bool) -> [AVp] -> Bool -> ([AVp],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 :: (AVp -> Bool) -> [AVp] -> ([AVp],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 :: Int -> [([AVp],Bool)] -> Maybe [[AVp]]
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 :: [([AVp],Bool)] -> Maybe [[AVp]]
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 :: AVp-> [[AVp]] -> (Maybe [[AVp]],Maybe [[AVp]])
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
-- | make root list with children from sorted possibles
rootLs :: [AVp]->[[AVp]]->[Maybe (AVp,[[AVp]])]
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 :: [[AVp]] -> [Maybe (AVp,[[AVp]])]
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 :: Maybe (AVp,[[AVp]]) -> Maytree AVp
mkAVMTree rtchls =
case rtchls of
Nothing -> Niets
Just (x,[]) -> Wel {avLabel = x, avChils = []}
Just (x, suborls) -> Wel {avLabel = x,
avChils = mkAVMFor suborls }
mkAVMFor:: [[AVp]] -> Mayfor AVp
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 AVp -> [[AVp]]
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 :: [[AVp]] -> [[AVp]]
extrMin ls = nubBy isEq [ getMinin x ls | x <-ls ]
where getMinin x y = foldr minLs x y
-- | final transformation of a conjunction of disjunctions to a disjunction of conjunctions
trAndOr :: [[AVp]] -> [Ant]
trAndOr orls =
extrMin (concatMap brMayTree for) where for = mkAVMFor orls
-- C: Verify the falsification result with the original positive antecedents
-- | erify the falsification result with the original positive antecedents
verify :: [Ant] -> [Ant] -> [Ant]
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 antecedents
-- | the implementation of the rule reduction (for one consequent attribute-value
redPos :: [Ant] -> [Ant] -> [Ant]
redPos p n = verify (trAndOr (fsfmatch (hypot p) n)) p
-------------------------------------------------------
-- Functions on the list of facts
-- | f2r works because only one value of an attribute can be in a fact.
-- and there is always one (possibly value -1 as defined by Codec)
f2r :: Int -> [AVp] -> (Ant,AVp)
f2r att fact = (ant, cons) where
(ant, [cons]) = partition (\u -> (fst u) /= att) fact
-- | remove all rules with blank consequent value.
f2rules :: Int -> [[AVp]] -> [Rule]
f2rules att facls = filter (\u -> (snd $ snd u) /= -1) raw where
raw = map (f2r att) facls
{- | partition a fact list according to the attribute-values of the consequent
Important: all rules with blank consequent values should have been removed by f2rules.
-}
facts2Rules :: Int -> [[AVp]] -> [[Rule]]
facts2Rules at facls =
partitionBy (\x y -> (snd x) == (snd y)) ruls where
ruls = f2rules at facls
-- | the reduction algorithm for each consequent is implemented by redPos p n
redOne :: [[Rule]] -> [Rule] -> [Rule]
redOne grp rls = map addcons (redPos p n) where
p = map fst rls
n = map fst (concat $ (delete rls grp))
addcons x = (x,cons)
cons= (snd . head) rls
-- | add a sort by length to reduction of one consequent value
sortedRedOne :: [[Rule]] -> [Rule] -> [Rule]
sortedRedOne grp rls = sortByValNum $ redOne grp rls
-- | reduce a rule model for all consequent attribute-value pairs
reduceAll :: [[Rule]] -> [[Rule]]
reduceAll rlgrp = map (sortedRedOne rlgrp) rlgrp
-----------------------------------------------------------------------------
{- | find ambiguities in a rule group. A rule group partitions rules according to the consequent values.
Equal facts must have been removed, otherwise they will show up too.
Warning: only works if the Antedent rows have the same attribute order.
-}
getAmbiguous :: [[Rule]] -> [[Rule]]
getAmbiguous grp = filter (\x -> (length x) > 1) anteqs where
anteqs = partitionBy (\x y -> (fst x) == (fst y)) ols
ols = concat grp
----------------------------------------------------------------------------------------------------