Emping-0.5: src/Abduce.hs
{- | 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