Emping-0.6: src/Reduce.hs
{- | Emping 0.6 (provisional)
Tue 19 May 2009 05:53:08 PM CEST
Module Reduce implements the three stage algorithm to derive all shortest rules from a (coded) table of nominal rules.
A rule is a tuple of an antecedent and a consequent (type synonym Rule).
A consequent is an attribute value tuple (type synonym AVp).
An antecedent is a Set of AVp pairs (type synonym Antec).
Rules may be ambiguous (same antecedent, different consequent).
If all rules for some consequent are ambiguous, the antecedent list is empty. -}
module Reduce ( reduceAll ) where
import Data.Set (Set)
import qualified Data.Set as Reduce
import Data.List (partition, delete, nub )
import Codec (AVp)
import DefRules (Antec, Rule )
-------------- usage of Data.Set functions ---------------
-- strict foldl1' for union of sets in a list
-- GHC Set docs say that (big `union` small) is best
set_unions :: Ord a => [Set a] -> Set a
set_unions = Reduce.unions -- foldl1' Reduce.union better ????
set_diff :: Ord a => Set a -> Set a -> Set a
set_diff = Reduce.difference
set_member :: Ord a => a -> Set a -> Bool
set_member = Reduce.member
set_map :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b
set_map = Reduce.map
set_findMax :: Set a -> a
set_findMax = Reduce.findMax
set_delete :: Ord a => a -> Set a -> Set a
set_delete = Reduce.delete
set_null :: Ord a => Set a -> Bool
set_null = Reduce.null
set_filter :: Ord a => (a -> Bool) -> Set a -> Set a
set_filter = Reduce.filter
set_singleton :: Ord a => a -> Set a
set_singleton = Reduce.singleton
set_insert :: Ord a => a -> Set a -> Set a
set_insert = Reduce.insert
set_isSubsetOf :: Ord a => Set a -> Set a -> Bool
set_isSubsetOf = Reduce.isSubsetOf
-----------------------------------------------------------
-- A,B and C: the reduction algorithm in its three steps
-- A: formulate hypothesis from the antecedents of rules for a consequent
-- returns a disjunction of AVp pairs, not an antecedent
hypot :: [Antec] -> Set AVp
hypot pa = set_unions pa
-- B: falsify the hypothesis
-- B1. match with all the antecedents of other than the consequent
-- the reduction result as a (conjunctive) list of AVp disjunctions
fsfmatch :: Set AVp -> [Antec] -> [Set AVp]
fsfmatch hyp na = map (set_diff hyp) na
-- B2. transform conjunction of disjunctions into disjunction of conjunctions
-- count the occurrence of an element in a list of OR_sets and return it, with its count
countInOrs :: AVp -> [Set AVp] -> (Int,AVp)
countInOrs x orls = (n,x) where
n = length $ filter (set_member x) orls
-- for all elements present in a list of OR-sets, return them with their counts
countAllInOrs :: [Set AVp] -> Set (Int,AVp)
countAllInOrs orls = set_map (flip countInOrs orls) (set_unions orls)
-- the root of the (sub) tree is the most occurring AVp
-- depends on the default ordering of tuples!!
-- N.B. for each new OR_set list, the most occurring AVp must be recalculated!!
getRoot :: [Set AVp] -> AVp
getRoot orls = snd $ set_findMax (countAllInOrs orls)
-- growing to the right, with the OR_lists which do not contain the root, and
-- the OR_lists, which do contain the root, with that root removed
-- except if that rest is empty
restRight :: AVp -> [Set AVp] -> [Set AVp]
restRight rt orls | orls == [] || any set_null dlrt = []
| otherwise = dlrt ++ nort
where (ysrt, nort) = partition (set_member rt) orls
dlrt = map (set_delete rt) ysrt
-- growing down from the root, OR_lists with the root are represented by the root itself
-- any elements with the same attribute as the root must be removed from the porls (possible or set lists)
rootDown :: AVp -> [Set AVp] -> Maybe (AVp,[Set AVp])
rootDown rt orls | porls == [] = Just (rt,[])
| any set_null porls = Nothing
| otherwise = Just (rt, porls)
where nort = filter (\s -> not (set_member rt s)) orls
porls = map (remWithAtt (fst rt)) nort
remWithAtt a s = set_filter (\e -> (fst e) /= a) s
-- construct a level of possible roots and OR_set lists
rootLevel :: [Set AVp] -> [Maybe (AVp,[Set AVp])]
rootLevel [] = []
rootLevel orls = rtwch:(rootLevel next)
where rt = getRoot orls
rtwch = rootDown rt orls
next = restRight rt 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]
-- construct a Mayfor from a list of OR_sets
mkAVMFor:: [Set AVp] -> Mayfor AVp
mkAVMFor suborls = map mkAVMTree rtchls where
rtchls = rootLevel suborls
-- construct a MayTree from Maybe roots and source children
mkAVMTree :: Maybe (AVp,[Set 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 }
-- get the branches of a Maytree. The empty lists are lost because of concatMap
brMayTree :: Maytree AVp -> [Antec]
brMayTree t = case t of
Niets -> []
(Wel x []) -> [set_singleton x]
(Wel x for) -> map (set_insert x) brls where
brls = concatMap brMayTree for
-- returns x if it's elements are all in y, otherwise y
minSet :: Ord a => Set a -> Set a -> Set a
minSet x y | x `set_isSubsetOf` y = x
| otherwise = y
-- extract the smallest sublists from the orlist of andlists
extrMin :: [Antec] -> [Antec]
extrMin ls = nub [ getMinin x ls | x <-ls ]
where getMinin x y = foldr minSet x y
-- the function to transform (ANDs of ORs) to (ORs of ANDs)
transOrToAnd :: [Set AVp] -> [Antec]
transOrToAnd = extrMin . (concatMap brMayTree) . mkAVMFor
----------------------------------------------------------------------------------------------
-- C: Verify the falsification result with the original positive antecedents
-- test whether an unfalsified antec is a subset of an original rule
verifOne :: Antec -> [Antec] -> Bool
verifOne nf ruls = any (\s -> nf `set_isSubsetOf` s) ruls
verify :: [Antec] -> [Antec] -> [Antec]
verify allnf ruls = filter (flip verifOne ruls) allnf
------------------- not used for now -------------------------------
--potential :: [Antec] -> [Antec] -> [Antec]
--potential allnf ruls = filter (not . (flip verifOne ruls)) allnf
-- transform lists of antecedents to rules
antecsToRules :: [Antec] -> AVp -> [Rule]
antecsToRules antecs av = zip antecs avls where
avls = replicate (length antecs) av
-- A, B and C: reduce a partition of rules
-- | reduce list of rules with the same consequent in a partition of rules
reduceOne :: [Rule] -> [[Rule]] -> [Rule]
reduceOne rls allrls | antecs == [] = []
| otherwise = antecsToRules ver cons
where rulants = (map fst rls)
cons = (snd . head) rls
h = hypot rulants
others = delete rls allrls
ors = fsfmatch h (map fst (concat others))
antecs = transOrToAnd ors
ver = verify antecs rulants
-- | reduce all rules in a rule partition and remove any empty rules
reduceAll :: [[Rule]] -> [[Rule]]
reduceAll allrules = filter (/= []) result where
result = map ((flip reduceOne) allrules) allrules