Emping-0.1: src/Reduce.hs

module Reduce ( redCons ) where

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

-- module: get the reduced normal form of a rule model
-- some general purpose functions

import Data.List (nub, (\\), nubBy, partition )

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

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

redPos :: (Eq a,Eq b) => [[(a,b)]] -> [[(a,b)]] -> [[(a,b)]]
redPos p n = verify (trAndOr (match (hypot p) n)) p

-- reduce a list of attribute-value pairs by selecting the
-- consequent. The consequent attribute is removed from p and n

-- remove the consequent attributes

rmAtt :: (Eq a, Eq b) => a -> [[(a,b)]] -> [[(a,b)]]
rmAtt at rws =  map rm rws where 
                    rm  ls = [y | y <- ls, at /= fst y ]

-- reduce the list of attribute- value pairs (no consequent)

redCons :: (Eq a, Eq b) => (a,b) -> [[(a,b)]] -> [[(a,b)]]
redCons x y = redPos p n where
                    z= partition (x `elem`) y 
                    p = rmAtt (fst x) (fst z)
                    n = rmAtt (fst x) (snd z)