{- | Emping 0.5 (provisional)

Module Abduce produces a graph of implications (equivalences in one node), between reduced antecedents with the same consequent.

Fri 04 Apr 2008 07:19:00 PM CEST 
-}
module Abduce (abduceTopAll, hasDependencies, orgReg2Ndg, nodeLegend, implicGraphOne, implicGraphAll, RuRe ) where
import Aux
import Data.List ( findIndices, nubBy, nub, (\\) )
import Data.Graph.Inductive
import Control.Monad.State

--------------------------------------------------------------------------------
-- Match indices of reduced rules with indices of the original(s) which include a reduced rule

-- | indices of original rule(s) denoted by the same reduced rule. The antecedents of the original are supersets of the reduced antecedent.
redOrgs :: [Rule] -> Rule -> [Int]
redOrgs rules red = findIndices (\x -> (fst red) `isSub` (fst x)) rules

-- | tuples of the indices of originals and of the reduced rules for orgs and reds with same av consequent. First the originals, second the reduced rule.
redOPrs :: [Rule] -> [Rule] -> [([Int], Int)]
redOPrs rules reds = zip orixls [0..] where
           orixls = map (redOrgs rules) reds

-- | define a type synonym for rule indices and reduced rule indices. First the rule indices, then the reduced indices.
type RuRe = ([Int], [Int])
-- ^ Second is a node in the graph (of equals), first determines the order.


-- | get all reduced rules denoting the same original (ONE). First is originals, second is reduced equals.
getEquals :: [([Int],Int)] -> ([Int],Int) -> RuRe
getEquals  y  (ols,_)=
      (ols, [snd x | x <- y, fst x == ols ])

-- | group original-red pairs into original-equals pairs, remove doubles of original indices (maybe same but in different order)
toEquals :: [([Int],Int)] -> [RuRe]
toEquals orpl = nubBy eqOrg ls where
     ls = map (getEquals orpl) orpl
     eqOrg (x1,_) (x2,_) = isSub x1 x2 && isSub x2 x1

-- | first original indices, second reduced rule indices, matched from original rules to reductions with the same consequent av
redOrgs2Eqs :: [Rule] -> [Rule] -> [RuRe]
redOrgs2Eqs rules reds = toEquals (redOPrs rules reds)

-------------------------------------------------------------------------------
-- Get the implications (partially ordered through the originals they denote)

-- | define a partial order (WITHOUT EQUALS)
data Porder = HI | LW | NT deriving (Eq)

-- | define a comparison function for the partial order of an original rules - equal reductions (indices) pair
pcompare :: RuRe -> RuRe -> Porder
pcompare (x1, _) (x2, _)
         | isSub x2 x1 = HI
         | isSub x1 x2 = LW
         | otherwise = NT

---------------- Top Level Equals (no graph involved)----------------------

-- | get the top of a RuRe pair in a list
getTp :: [RuRe] -> RuRe -> RuRe
getTp ls x = foldr cmpmax x ls where 
                     cmpmax u v | pcompare u v == HI = u
                                | otherwise = v

-- | get all tops from a RuRe list
getTops :: [RuRe] -> [RuRe]
getTops ls = nub $ map (getTp ls) ls

-- | get the indices of the tops
eqixTops :: [Rule] -> [Rule] -> [[Int]]
eqixTops rules  reds =  map snd (getTops $ redOrgs2Eqs rules reds)

-- | replace indices of equals list with actual rule list (of reduced rules) and sort by length
srteqix2reds :: [Rule] -> [Int] -> [Rule]
srteqix2reds reds exls = sortByValNum $ map (reds !!) exls

-- | get the top level for the reductions of a consequent av
abduceTopOne :: [Rule] -> [Rule] -> [[Rule]]
abduceTopOne rules reds = map (srteqix2reds reds) (eqixTops rules reds)

srtabduceTopOne :: [Rule] -> [Rule] -> [[Rule]]
srtabduceTopOne rules = sortListEqs . (abduceTopOne rules)

-- | check if the top level differs in length from the reduced list. No dependencies if not.
hasEDOne :: [[Rule]] -> [Rule] -> Bool
hasEDOne tops reds | (length tops) == (length reds) = False
                   | otherwise = True

-- | get the top levels for the reductions of all values of the consequent attribute
abduceTopAll :: [[Rule]] -> [[Rule]] -> [[[Rule]]]
abduceTopAll rulegrp redsgrp = zipWith srtabduceTopOne rulegrp redsgrp

-- | check the top levels for all consequent values for equals and dependencies
hasDependencies :: [[[Rule]]] -> [[Rule]] -> Bool
hasDependencies topsgrp redsgrp = or $ zipWith hasEDOne topsgrp redsgrp


-------------------------------------------------------------------------
-------------------------------------------------------------------------
-- Build a directed graph of the implications (top down, each edge an entailment).

-- | get nodes from a list of original rules-reductions pairs (start = 1) for an av
myGetNodes :: [RuRe] -> [LNode RuRe]
myGetNodes rurls = zip [1..] rurls

-- | update nodes to get a linear sequence (of nodes)
myUpdateNodes :: [LNode RuRe] -> State Node [LNode RuRe]
myUpdateNodes ndrurls = 
      State (\n -> ( map (plusprior n) ndrurls , n + length ndrurls )) where
                                  plusprior x (nd, rur) = (nd + x, rur)

-- | update all the nodes for an attribute, so they range from 1 to the total number.
contNodes :: [[LNode RuRe]] -> [[LNode RuRe]]
contNodes ndgrls = evalState (mapM myUpdateNodes ndgrls) 0

-- | get labeled nodes from original rules and reductions
rr2Nds :: [Rule] -> [Rule] -> [LNode RuRe]
rr2Nds rules reds = myGetNodes $ redOrgs2Eqs rules reds 

-----------------------------------------------------------------------------------
-----------------------------------------------------------------------------------
-- | get labeled nodes from rulegroup and reduction group. THIS is the BASE for all graphs.
orgReg2Ndg :: [[Rule]] -> [[Rule]] -> [[LNode RuRe]]
orgReg2Ndg  rulegrp redgrp = contNodes (zipWith rr2Nds rulegrp redgrp)
-----------------------------------------------------------------------------------
-----------------------------------------------------------------------------------

-- | nodes with reduced reduction equivalences (reds are the reductions for an av)
nodesWRls :: [Rule] -> [LNode RuRe] -> [LNode [Rule]]
nodesWRls reds rurls = map getrule rurls where 
                          getrule (nod, (_,re)) = (nod, srteqix2reds reds re)

-- | get nodes with the indices of the reduction equivalences
nodeLegend :: [[Rule]] -> [[LNode RuRe]] -> [LNode [Rule]]
nodeLegend redsgrp nodegrp = concat $ zipWith nodesWRls redsgrp nodegrp

------------------- get the edges from a list of LNode RuRe --------------

-- | just like getTp, but with nodes (functor here?)
getNdTp :: [LNode RuRe] -> LNode RuRe -> LNode RuRe
getNdTp nodls nod =  
      foldr ndcmpmax nod nodls where 
                   ndcmpmax (nd1,x) (nd2,y) | pcompare x y == HI = (nd1,x)
                                            | otherwise = (nd2,y)

-- | get the top level from a node list (just like getTops)
getNodeTops :: [LNode RuRe] -> [LNode RuRe]
getNodeTops ndls = nub $ map (getNdTp ndls) ndls

-- | split a RuRe list into levels, each level the top of the next lower.
getNodeLevels :: [LNode RuRe] -> [[LNode RuRe]]
getNodeLevels [] = []
getNodeLevels nodls = (getNodeTops nodls):(getNodeLevels $ (nodls \\ (getNodeTops nodls)))

-- | get the edges from a top node to the next lower level
myGtUEdge :: [LNode RuRe] ->  LNode RuRe-> [UEdge]
myGtUEdge lvs tn = zip3 src trgt etyp where
                    src = replicate (length lvs) (fst tn)
                    trgt = map fst rurls
                    etyp = replicate (length lvs) ()
                    rurls = filter (nodecompare tn)  lvs
                    nodecompare (_,x) (_,y) = (pcompare x y) == HI

-- | get the edges from a top level to a lower level (the next)
topUEdges :: [LNode RuRe] -> [LNode RuRe] -> [UEdge]
topUEdges lv1 lv2 = concatMap (myGtUEdge lv2) lv1

-- | get all edges from a level list. Case of only one level returns []
allLevelUEdges :: [[LNode RuRe]] -> [UEdge]
allLevelUEdges [] = error "Abduce allLevelUEdges: list is empty"
allLevelUEdges (_:[]) = []
allLevelUEdges (x:y:ys) = (topUEdges x y) ++ (allLevelUEdges (y:ys))

-- | from a list of nodes, get the corresponding edges
myGetUEdges :: [LNode RuRe] -> [UEdge]
myGetUEdges = allLevelUEdges . getNodeLevels

-- | replace the RuRe with the length of the equivalence list
disrure :: [LNode RuRe] -> [LNode (Int,Int)]
disrure  nodls = map rur2ln nodls where
                          rur2ln (nd, (_ , redidls)) = (nd, (nd, (length redidls))) 

-- | make a graph of a node list
implicGraphOne :: [LNode RuRe] -> Gr (Int,Int) ()
implicGraphOne nodelist =  mkGraph nds edgs where
                                         nds = disrure nodelist
                                         edgs = myGetUEdges nodelist
                                      
-- | make a graph of the group of node lists
implicGraphAll :: [[LNode RuRe]] -> Gr (Int,Int) ()
implicGraphAll nodegroup = mkGraph nds edgs where
                                       nds = disrure $ concat nodegroup
                                       edgs = concatMap myGetUEdges nodegroup