{- | Emping 0.6 (provisional)

Tue 19 May 2009 05:53:47 PM CEST 

Module Abduce contains functions to find implications of reduced rules with
the same consequent. Each reduced rule stands for one or more originals.
Rule red1 implies red2 if the originals of red1 are a subset of the originals of red2.
Reduced rules, which imply the same original rule, form an equivalence class.
So the reduced rules for the same consequent are in a poset of equivalence classes.
The function abduceReds gets the graph of this poset from the lists of reduced and original rules. 

Sun 24 May 2009 07:10:00 PM CEST 

-}

module Abduce ( abduceReds, graphHasImps,graphMLGen ) where

import Data.Set (Set)
import qualified Data.Set as Abduce
import Data.List ( findIndices )
import Control.Monad.State
import Data.Maybe (isJust, fromJust)
import Data.Graph.Inductive
import DefRules (Rule)

---------------------- redefined set functions -----------------------
isSub :: Ord a => Set a -> Set a -> Bool
isSub = Abduce.isSubsetOf

set_fromList :: Ord a => [a] -> Set a
set_fromList = Abduce.fromList
----------------------------------------------------------------------

-- find indices of original rule(s) denoted by the same reduced rule 
-- antecedents of reduction are subsets (including equal) of the original
redIOrgsOne :: Rule -> [Rule] -> Set Int
redIOrgsOne red rules = 
     set_fromList $ findIndices (\x -> (fst red) `isSub` (fst x)) rules

-- tuples of the indices of originals for each reduced rule
-- first in tuple is the reduced rule index, second the indices of originals
redIOrgsAll :: [Rule] -> [Rule] -> [(Int, Set Int)]
redIOrgsAll reds rules = zip  [0..] orixls  where
            orixls = map (flip redIOrgsOne rules) reds

-- reduced rules may denote the same original rule (equivalence)
-- fst in the result is a list of equals, snd is the indices of originals
getEqualsOne :: (Int,Set Int) -> [(Int,Set Int)]  -> ([Int], Set Int)
getEqualsOne (_, orig) ls = (eqls, orig ) where
              eqls = [ fst x | x <- ls , snd x == orig ]

-- if a reduction is already in some equals list, ignore, otherwise get a new one
-- now every reduction is in one equivalence list, no duplicate lists
getEqsOneSt :: [(Int, Set Int)] -> (Int,Set Int) ->
                                State [Int] (Maybe ([Int], Set Int) )
getEqsOneSt ls r = 
     State (\s ->  let res = getEqualsOne r ls
                   in  if (fst r) `elem` s 
                          then (Nothing, s)
                          else (Just res, (fst res) ++ s) )

-- group all reduced rules, with originals, to equals with originals
groupEquals  :: [(Int, Set Int)] -> [([Int], Set Int)]
groupEquals ls = [ fromJust x | x <- mbeqls, isJust x ] where
                       mbeqls =  evalState (mapM (getEqsOneSt ls) ls) []

type ReRu = ([Int], Set Int)

-- | from the list of reductions and the list of rules (all same consequent) 
-- get equivalent reductions with their original rule indices)
eqivRedRulS :: [Rule] -> [Rule] -> [ReRu]
eqivRedRulS  reds ruls =  groupEquals $ redIOrgsAll reds ruls

-------------------------------------------------------------------------------
{- get implications between equivalence classes of reduced rules
   the partial order (of the implication relation) is found through the originals
   red1 implies red2 if origs set of red1 is a subset of origs set of red2 
   the rule which implies less originals, implies the rule which implies more -}

reruToNode :: [ReRu] -> [LNode ReRu]
reruToNode reruls = zip [1..] reruls

--  partial order (no equals, these are caught inthe equivalence lists)
--                HI = high, LW = low, NT = not ordered
data Porder = HI | LW | NT deriving (Eq)

--  poset comparison: the smaller (LW)  implies the larger (HI)
--  isSubsetOf from from Data.Set (could also use isProperSubsetOf)
pcomp :: LNode ReRu -> LNode ReRu -> Porder
pcomp (_,(_, x1)) (_,(_,x2))   | isSub x1 x2 = LW
                               | isSub x2 x1 = HI
                               | otherwise = NT

---------------  get a graph of the poset by implication  ------------------------

{- add a possible node to an adjacency list. If it is a superset of any in
   the list, then ignore. If it is unconnected to all others , add it.
   If it is a subset of some members, replace those with it. -}
newLub :: LNode ReRu -> [LNode ReRu] -> [LNode ReRu]
newLub mb lubs | any (\x -> (pcomp x mb) == LW) lubs = lubs
               | all (\x -> (pcomp x mb) == NT) lubs = mb:lubs
               | otherwise = mb:newlubs
                     where newlubs = filter (\x -> (pcomp x mb) /= HI) lubs


-- if a ReRu implies another, it is a possible member of the adjacency list
addLub :: LNode ReRu -> LNode ReRu -> State [LNode ReRu] (LNode ReRu)
addLub nod mb =  State (\s -> if (pcomp nod mb) == LW
                                 then (nod , newLub mb s)
                                 else (nod, s) )

-- N.B nod must NOT be a member of mbls! This is batch , starts from []
getAdj :: LNode ReRu -> [LNode ReRu] -> [LNode ReRu]
getAdj  nod mbls =  execState (mapM (addLub nod) mbls) []

-- get  a node with its nearest implications
getAdjPair :: LNode ReRu -> [LNode ReRu] -> (LNode ReRu,[LNode ReRu])
getAdjPair nod nodls = (nod, adj) where
                                    adj = getAdj nod src
                                    src = filter (/= nod) nodls

-- get the (node, adjacency list) tuples for all elements of a LNode ReRu list
getAdjPairAll :: [LNode ReRu] -> [(LNode ReRu,[LNode ReRu])]
getAdjPairAll reruls = map ((flip getAdjPair) reruls) reruls

-- type synonym for just the indices of reductions
type Re = [Int]

-- in a node with its closest implications, we don't need the originals any more
remOrigsFromNodes :: [(LNode ReRu, [LNode ReRu])] -> [(LNode Re, [LNode Re])]
remOrigsFromNodes napls = map redsonly napls where 
                   redsonly (nd, adj) = (remfn nd, map remfn adj)
                   remfn (x,(r, _)) = (x,r)
                   
-- get the list of nodes to build the graph (all types)
-- if the adjacency list is empty, the node is unconnected, but still in the graph
nodesFromNodeAdjList :: [(LNode a, [LNode a])] -> [LNode a]
nodesFromNodeAdjList ndals = map fst ndals

-- get the list of edges from a node adjacency list (all types of Eq (?))
-- if the adjacency list is empty, there are no edges for that node
edgesFromNodeAdj :: Eq a => (LNode a, [LNode a]) -> [UEdge]
edgesFromNodeAdj (nd, adj) | adj == [] = []
                           | otherwise  = zip3 src tgt typ  
                           where tgt = map fst adj
                                 n = length tgt
                                 src = replicate n (fst nd)                       
                                 typ = replicate n () 

-- get the list of edges to build the graph (all types of Eq (?) )
-- N.B. concat takes care of any empty edge lists
edgesFromNodeAdjList  :: Eq a => [(LNode a,[LNode a])] -> [UEdge]
edgesFromNodeAdjList = concatMap edgesFromNodeAdj

-- get the reduced rules themselves from a node
reToRed :: [Rule] -> LNode Re -> LNode [Rule]
reToRed reds (nd,ils) = (nd, map (reds !!) ils)

-- change all indices in a node list to the rules themselves
reToRedAll :: [Rule] -> [LNode Re] -> [LNode [Rule]]
reToRedAll reds  ndls = map (reToRed reds) ndls

-- from reductions and their originals, get a graph of reduced rules
-- each edge represents an implication, the first implies the second
abduceReds :: [Rule] -> [Rule] -> Gr [Rule] ()
abduceReds reds ruls =  mkGraph nds eds where                              
                  nds   = reToRedAll reds (nodesFromNodeAdjList nda)
                  eds = edgesFromNodeAdjList nda 
                  nda   = (remOrigsFromNodes 
                          .  getAdjPairAll 
                          . reruToNode   
                          . (eqivRedRulS  reds)) ruls 
--------------------------------------------------------------------                
----------------------------- graph analysis -----------------------

-- | check if a graph has any rule implications  at all
graphHasImps :: Gr [Rule] () -> Bool
graphHasImps gr | edges gr == [] = False
                | otherwise = True

-- workaround gsel to get tops and bottoms of a graph
lnodesMLGen :: Bool -> Gr [Rule] () -> [LNode [Rule]]
lnodesMLGen msg ag = [ (n,l) | (n,l) <- labNodes ag, mldeg ag n == 0 ]
                            where mldeg = if msg then outdeg else indeg

graphMLGen :: Bool -> Gr [Rule] () -> Gr [Rule] ()
graphMLGen msg ag = mkGraph nds [] where nds = lnodesMLGen msg ag