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