Emping-0.2: src/Reduce.hs

module Reduce (isSub,f2Grp, redAll, ambOrg ) where

-- (c) 2007 Hans van Thiel
-- Version 0.2 License GPL

{- 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, isSuper :: Eq a => [a] -> [a] -> Bool
isSub [] y = True
isSub (x:xs) y | not (x `elem` y) = False
               | otherwise = isSub xs y

isSuper = flip isSub

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 eq [] = []
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 \\) 

--    2. transform the orlist of andlists to andlist of orlists

-- test if an attribute is in the list and get it

attElem :: (Eq a, Eq b) => (a,b) -> [(a,b)] -> Maybe (a,b)
attElem x [] = Nothing
attElem x (y:ys) = if fst x == fst y then Just y
                                     else attElem x ys
{- and a predicate to an andlist
     attributes with different values contradict
     attributes with the same value are equal -}

andP :: (Eq a,Eq b) => (a,b) -> [(a,b)] -> [(a,b)]
andP x ans = case attElem x ans of 
                   Nothing -> x:ans
                   Just y -> if snd x == snd y 
                                    then ans
                                    else []            

-- first: anding an orlist to an orlist of andlists
-- remove all the empty lists

repandPls :: (Eq a,Eq b) => [(a,b)] -> [[(a,b)]] -> [[(a,b)]]
repandPls ors als = 
    filter (/= []) [ andP x y | x <- ors, y <- als ]

-- then: extract the smallest sublists from an 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

-- B.2.1: anding an orlist to an orlist of andlists

andOrAnds :: (Eq a,Eq b) => [(a,b)] -> [[(a,b)]] -> [[(a,b)]]
andOrAnds x = extrMin . (repandPls x)

-- B.2.2: transform andlist of orlists to orlist of andlists in batch

trAndOr :: (Eq a,Eq b) => [[(a,b)]] -> [[(a,b)]]
trAndOr x = foldr andOrAnds (raise (last x)) (init x)
                 where raise ls = [ [y] | y <- ls]

-- 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