Emping-0.4: src/Abduce.hs

{-# LANGUAGE TypeSynonymInstances #-}
{- | Emping 0.4 (provisional)

Module Abduce gets implications, including equals, between reduced antecedents with the same consequent (if present).

Warning: because of the use of tuple type synonym RuRe as a Poset instance, the  compiler needs the  -XTypeSynonymInstances flag.

-}
module Abduce (abduceAll, cntEDAbduction)  where

import Aux ( isSub, Rule )
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 general partially ordere set (Poset) WITHOUT EQUALS
data Porder = HI | LW | NT deriving (Eq)

-- | define the Poset class
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
-- | the second half of the definition
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   


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)

-- | put a list of partially ordered elements in a forest
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) which include a reduced rule

-- | indices of original rule(s) denoted by the same reduced rule. The antecedents 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
redOPrs :: [Rule] -> [Rule] -> [([Int], Int)]
redOPrs rules reds = zip orixls [0..] where
           orixls = map (redOrgs rules) reds

-- | get all reduced rules denoting the same original (ONE). First is originals, second is 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 pairs, 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 :: [Rule] -> [Rule] -> [([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 a type synonym for rule indices and reduced rule indices. First the rule indices, then the reduced indices
type RuRe = ([Int], [Int])


-- | first in orig is high, low or not ordered. GHCi needs -XTypeSynonymInstances because of this.
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 :: [Rule] -> [Rule] -> 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 :: [Rule] -> [Rule] -> Forest [Int]
reds2EqsFor rules reds = 
              remOrgs (redOrgs2Forest rules reds)

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

eqix2reds :: [Rule] -> [Int] -> [Rule]
eqix2reds reds exls = map (reds !!) exls

-- | from a list of original rules and their reductions, get the partial order of the reductions (with the consequent)
abd1Val :: [Rule] -> [Rule] -> Forest [Rule]
abd1Val rules reds = map trmf for where
               trmf = treeMap (eqix2reds reds)
               for = reds2EqsFor rules reds
------------------------------------------------------

-- | abduce all reductions for a selected attribute
abduceAll :: [[Rule]] -> [[Rule]] -> [ Forest [Rule] ]
abduceAll rulegrp redsgrp = zipWith abd1Val rulegrp redsgrp

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

--------------------------------------- Functions on a Tree of Rules --------------------------------

-- | check whether a tree contains equals or dependencies
treehasED :: Tree [Rule] -> Bool
treehasED t | length (rootLabel t) == 1 
              && subForest t == [] = False
            | otherwise = True

-- | count equals and dependencies  forest. The first is the number of chains (including equals), the second the  number of singles.
cntEDVal :: Forest [Rule] -> (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 equals or dependencies in attribute abduction. The first is the ED count, the second is the number of single (unconnected) rules.
cntEDAbduction ::  [Forest [Rule] ] -> (Int,Int)
cntEDAbduction forls = (dep, uncon) where
             dep = sum $ fst (unzip temp)
             uncon = sum $ snd (unzip temp) 
             temp = map cntEDVal forls
-----------------------------------------------------------------------------------------------------