Emping-0.2: src/Abduce.hs

module Abduce ( abdAll, treehasED, cntEDAtt ) where

-- (c) 2007 Hans van Thiel
-- Version 0.2 License GPL

-- module: get partial order, if any, of RNF rules

import Reduce (isSub )
import Data.List ( findIndices, nubBy, partition )
import Data.Tree ( Tree(..), Forest )

-- general purpose functions

-- tree map (fmap not accessible from Data.Tree (???)

treeMap :: (a -> b) -> Tree a -> Tree b
treeMap f (Node x ts) = Node (f x) (map (treeMap f) ts)


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

-- define a Poset (WITHOUT EQUALS)

data Porder = HI | LW | NT deriving (Eq)

class (Eq a) => Poset a where
    pcompare :: a -> a -> Porder

-- put a poset in a tree, each branch is an ordered chain
-- unordered elements are in the same subforest

ins2Tree :: Poset a => a -> Tree a -> Tree a
ins2Tree x t = 
 case pcompare x (rootLabel t) of
    LW -> Node (rootLabel t) (ins2Forest x (subForest t))
    HI -> Node x (t:[])
    NT -> t

ins2Forest :: Poset a => a -> Forest a -> Forest a
ins2Forest x [] = (Node x []):[]
ins2Forest x for 
  | new == for = (Node x []):for
  | otherwise = new
    where new = map (ins2Tree x) for   

-- put a list of partially ordered elements in forest

isRoot :: Poset a => [a] -> a -> Bool
isRoot ls x = and $ map ((LW /=) . (x `pcompare`)) ls 

initRoots :: Poset a => [a] -> Forest a
initRoots ls = map ((flip Node) []) ls

lsinFor :: Poset a => [a] -> Forest a -> Forest a
lsinFor [] for = for
lsinFor (x:xs) for = ins2Forest x (lsinFor xs for)

list2Forest :: Poset a => [a] -> Forest a
list2Forest ls = lsinFor res for where
                     (x,res) = partition (isRoot ls) ls 
                     for = initRoots x  
-----------------------------------------------------
-----------------------------------------------------

-- A: match indices of reduced rules with indices of 
-- the original(s) denoted by a reduced rule

-- indices of original rule(s) denoted by reduced
-- rule. Note: consequent included, for simplicity

redOrgs :: (Eq a, Eq b) => [[(a,b)]] -> [(a,b)] -> [Int]
redOrgs rules red = findIndices (red `isSub`) rules

-- tuples of the indices of  originals and the reduced
-- rule index for orgs and reds with same av consequent

redOPrs :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]] -> [([Int],Int)]
redOPrs rules reds = zip orixls [0..] where
           orixls = map (redOrgs rules) reds

-- get all reds denoting the same original (ONE)
-- Note: first denote originals, second reduced equals

getEquals :: [([Int],Int)] -> ([Int],Int) -> ([Int],[Int])
getEquals  y  (ols,_)=
      (ols, [snd x | x <- y, fst x == ols ])

-- group original-red pairs into original-equals paire
-- remove doubles of origs, maybe same, different order

toEquals :: [([Int],Int)] -> [([Int],[Int])]
toEquals orpl = nubBy eqOrg ls where
     ls = map (getEquals orpl) orpl
     eqOrg (x1,y1) (x2,y2) = isSub x1 x2 && isSub x2 x1
-------------------------------------------------------

-- first orig indices, second red indices matched
-- from rules to reds with same consequent av

redOrgs2Eqs :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]] -> [([Int],[Int])]
redOrgs2Eqs rules reds = toEquals (redOPrs rules reds)
------------------------------------------------------

-- B: show partial order, according to sublists of origs
-- the reds are in implication chain of orig sublists

-- define type RuRe as a poset

type RuRe = ([Int],[Int])

-- first in orig is high, low or not ordered

instance Poset RuRe where
     pcompare (x1,y1) (x2,y2)
              | isSub x2 x1 = HI
              | isSub x1 x2 = LW
              | otherwise = NT
---------------------------------------------------


-- convert rules and reds for same consequent into
-- a poset forest

redOrgs2Forest :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]] -> Forest RuRe
redOrgs2Forest rules reds = 
          list2Forest (redOrgs2Eqs rules reds)

-- order is determined, original indices no longer needed

remOrgs :: Forest RuRe -> Forest [Int]
remOrgs for =  map (treeMap snd) for

-- produces the partial order of reduceds, with
-- indices of equals in one list (rules WITH cons)

reds2EqsFor :: (Eq a, Eq b)=> [[(a,b)]] -> [[(a,b)]] -> Forest [Int]
reds2EqsFor rules reds = 
              remOrgs (redOrgs2Forest rules reds)

-- replace indices list with rule list (of equals)

eqix2reds :: (Eq a, Eq b) => [[(a,b)]] -> [Int] -> [[(a,b)]]
eqix2reds reds exls = map (reds !!) exls

-- from a list of original rules and their reductions
-- get the partial order of the reductions (with conseq)

abd1Val :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]] -> Forest [[(a,b)]]
abd1Val rules reds = map trmf for where
               trmf = treeMap (eqix2reds reds)
               for = reds2EqsFor rules reds
------------------------------------------------------

-- abduce all reductions for a selected attribute

abdAll :: (Eq a, Eq b) => [[[(a,b)]]] -> [[[(a,b)]]] -> [ Forest [[(a,b)]] ]
abdAll rulegrp redsgrp = zipWith abd1Val rulegrp redsgrp

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

-- check if a tree contains a branch and/or equals

treehasED :: (Eq a, Eq b) => Tree [[(a,b)]] -> Bool
treehasED t | length (rootLabel t) == 1 
              && subForest t == [] = False
            | otherwise = True

-- count branches and/or equals in forest, 
-- fst is number of chains, snd number of singles

cntEDVal :: (Eq a, Eq b) => Forest [[(a,b)]] -> (Int,Int)
cntEDVal for = (dep, sin) where 
       dep = sum $ fst (unzip temp) 
       sin = sum $ snd (unzip temp) 
       temp = map (mark . treehasED) for  
       mark x | x == True = (1,0)
              | x == False = (0,1) 

-- count branches and/or equals in attribute abduction
-- fst is chain count, snd is number of unconnected rules

cntEDAtt :: (Eq a, Eq b) => [Forest [[(a,b)]] ] -> (Int,Int)
cntEDAtt forls = (dep, sin) where
             dep = sum $ fst (unzip temp)
             sin = sum $ snd (unzip temp) 
             temp = map cntEDVal forls