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

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

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

-- B.2 falsification

-- count the occurrences of something in a list and 
-- return the list without it (if it is an element)

delCount :: Eq a => a -> [a] -> (Int, [a])
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 :: Eq a => [a] -> [(a, 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 :: Eq a => [(a,Int)] -> [(a,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. (a is an av pair in Reduce, not needed)

mkavRtLs :: Eq a => [[a]] -> [a]
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 :: Eq a => (a -> Bool) -> [a] -> Bool -> ([a],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 :: Eq a => (a -> Bool) -> [a] -> ([a],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 ::(Eq a, Eq b) => a -> [([(a,b)],Bool)] -> Maybe [[(a,b)]]
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 :: (Eq a, Eq b) =>  [([(a,b)],Bool)] -> Maybe [[(a,b)]]
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 :: (Eq a, Eq b) => (a,b)-> [[(a,b)]] -> (Maybe [[(a,b)]],Maybe [[(a,b)]])
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
-- changes here ---------------------------- 

-- make root list with children from  sorted possibles  

rootLs :: (Eq a, Eq b)=>[(a,b)]->[[(a,b)]]->[Maybe ((a,b),[[(a,b)]])]
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 :: (Eq a, Eq b) => [[(a,b)]] -> [Maybe ((a,b),[[(a,b)]])]
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 :: (Eq a, Eq b) => Maybe ((a,b),[[(a,b)]]) -> Maytree (a,b)
mkAVMTree rtchls = 
   case rtchls of
         Nothing -> Niets
         Just (x,[]) -> Wel {avLabel = x, avChils = []}
         Just (x, suborls) -> Wel {avLabel = x, 
                                   avChils = mkAVMFor suborls }

mkAVMFor:: (Eq a, Eq b) => [[(a,b)]] -> Mayfor (a,b)
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 a -> [[a]]
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 :: Eq a => [[a]] -> [[a]]
extrMin ls =  nubBy isEq [ getMinin x ls | x <-ls ] 
          where  getMinin x y = foldr minLs x y

-- final transformation of an and-list of ors to or-list of ands
-- replaces the identically named function in Reduce in Emping 0.2

trAndOr :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]]
trAndOr orls = 
  extrMin (concatMap brMayTree for) where for = mkAVMFor orls

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