Emping-0.3.1: src/Abduce.hs

{-# LANGUAGE TypeSynonymInstances #-}
module Abduce ( abdAll, treehasED, cntEDAtt ) where

-- 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 mkLeaf ls where
            mkLeaf x = Node x []

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,_) (x2,_) = 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,_) (x2,_)
              | 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, single) where
       dep = sum $ fst (unzip temp)
       single = sum $ snd (unzip temp)
       temp = map (mark . treehasED) for
       mark x | x == True = (1,0)
              | otherwise = (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, uncon) where
             dep = sum $ fst (unzip temp)
             uncon = sum $ snd (unzip temp)
             temp = map cntEDVal forls