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

----------------------------------------------------------------------------------------------------