{- 

Author: Wishnu Prasetya, Joao Amorim

Copyright 2010 Wishnu Prasetya

The use of this sofware is free under the GNU General Public License
(GPL) version 3.

-}

module Sequenic.CTy.Combinations where

import Char
import List
import Maybe
import Sequenic.CTy.Types
-- import InputFigures

--Counts

-- | To count the maximum number of combinations induced by a classification tree.
nCombs :: CTree -> Int
nCombs [] = 1
nCombs (h:t) = (length (getClasses h))*(nCombs t)

-- | To count the number of categories in a classification tree.
nCats :: CTree -> Int
nCats x = length x


-- | To count the number of classes in a classification tree.
nClasses :: CTree -> Int
nClasses [] = 0
nClasses (h:t) = (length (getClasses h))+(nClasses t)


--Minimal Combination

-- | Generate a suite that minimally covers a classification tree. That is, such that
-- each class is covered at least once. 
minComb :: CTree -> Suite
minComb ctree = foldr1 sum_ . map getSingTestCases $ ctree


-- | Generate a suite that consisting of all possible combinations induced by a classification
-- tree.
fullComb :: CTree -> Suite
fullComb ctree = foldr1 product_ . map getSingTestCases $ ctree

-- | Function to normalize a Partition-expression by pushing 
-- negations inwards towards the atoms.
nnf :: Rule -> Rule
nnf (Neg (Neg p))    = nnf p
nnf (Neg (Andp p q)) = nnf (or_ (Neg p) (Neg q))
nnf (Neg (Andm p q)) = nnf (orm (Neg p) (Neg q))
nnf (Neg (Union p q)) = Intersect (nnf (Neg p)) (nnf (Neg q))
nnf (Neg (Intersect p q)) = Union (nnf (Neg p)) (nnf (Neg q))
nnf (Neg a) = Neg a
nnf (Andp p q) = Andp (nnf p) (nnf q)
nnf (Andm p q) = Andm (nnf p) (nnf q)
nnf (Union p q) = Union (nnf p) (nnf q)
nnf (Intersect p q) = Intersect (nnf p) (nnf q)
nnf a          = a


u `minus_` v     = filter (\x-> x `notElem` v) u
s `subsetOf` t   = all (\x-> x `elem` t) s

--
-- union of two suites over the same categories
--
st1 `union_` st2 = st1 ++ filter ok st2
   where
   ok t = not . any (\s-> s `subsetOf` t) $ st1

--
-- intersection of two suites over the same categories
--
st1 `intersect_` st2 = filter ok st2
   where
   ok t = any (\s-> s `subsetOf` t) $ st1

-- | Return the categories of a given Rule.
catOfP :: CTree -> Rule -> [String]
catOfP ct (All c)      = [c]
catOfP ct (Include ps) = map (fromJust . catOf ct) ps
catOfP ct (Neg p)      = catOfP ct p
catOfP ct (Andp p q)   = catOfP ct p ++ catOfP ct q
catOfP ct (Andm p q)   = catOfP ct p ++ catOfP ct q
catOfP ct (Union p q)  = catOfP ct p ++ catOfP ct q
catOfP ct (Intersect p q) = catOfP ct p ++ catOfP ct q

-- | Return the categories of a given rule.
catOfR ct (Rule_ p)     = catOfP ct p
catOfR ct (Rop _ r1 r2) = catOfR ct r1 ++ catOfR ct r2


-- | To check if a Rule is well-formed. 

chkP :: CTree -> Rule -> RuleError

chkP ct o@(All c)  = if c `elem` catNames ct then RuleOK
                     else RuleErr o

chkP ct o@(Include ps) = 
      if not (null ps) && allValid && isMonoset then RuleOK
      else RuleErr o
      where
      cats = map (catOf ct) ps
      allValid  = all isJust cats
      isMonoset = isSing (nub cats)

chkP ct (Neg p) = chkP ct p

chkP ct o@(Andp p q) = ep `errOR` eq `errOR` e3
      where
      ep = chkP ct p
      eq = chkP ct q 
      e3 = if    not (catsp `subsetOf` catsq)
             &&  not (catsq `subsetOf` catsp)
           then RuleOK
           else RuleErr o
      catsp = catOfP ct p
      catsq = catOfP ct q

chkP ct o@(Andm p q) =  ep `errOR` eq `errOR` e3
      where
      ep = chkP ct p
      eq = chkP ct q 
      e3 = if    not (catsp `subsetOf` catsq)
             &&  not (catsq `subsetOf` catsp)
           then RuleOK
           else RuleErr o
      catsp = catOfP ct p
      catsq = catOfP ct q

chkP ct o@(Union p q) = ep `errOR` eq `errOR` e3
      where
      ep = chkP ct p
      eq = chkP ct q 
      e3 = if    catsp `subsetOf` catsq
              && catsq `subsetOf` catsp
           then RuleOK
           else RuleErr o
      catsp = catOfP ct p
      catsq = catOfP ct q

chkP ct o@(Intersect p q) = ep `errOR` eq `errOR` e3
      where
      ep = chkP ct p
      eq = chkP ct q 
      e3 = if    catsp `subsetOf` catsq
              && catsq `subsetOf` catsp
           then RuleOK
           else RuleErr o
      catsp = catOfP ct p
      catsq = catOfP ct q


isSing []  = False
isSing [x] = True
isSing _   = False

data RuleError = RuleOK
               | RuleErr Rule
               | XRuleErr XRule
               deriving (Eq,Show)

isRuleOK RuleOK = True
isRuleOK  _     = False
isRuleErr (RuleErr _) = True
isRuleErr _           = False  
isXRuleErr (XRuleErr _) = True
isXRuleErr _           = False

errOR RuleOK e2 = e2
errOR e1 _      = e1

infixr 4 `errOR`

-- | Check if a rule is well-formed.
--
chkR :: CTree -> XRule -> RuleError

chkR ct (Rule_ p) = chkP ct p

chkR ct r@(Rop PLUS r1 r2) = e1 `errOR` e2 `errOR` e3
      where
      e1 = chkR ct r1
      e2 = chkR ct r2
      e3 = if not (cats1 `subsetOf` cats2) &&  not (cats2 `subsetOf` cats1)
           then RuleOK 
           else XRuleErr r
      cats1 = catOfR ct r1
      cats2 = catOfR ct r2

chkR ct r@(Rop TIMES r1 r2) = e1 `errOR` e2 `errOR` e3
      where
      e1 = chkR ct r1
      e2 = chkR ct r2
      e3 = if not (cats1 `subsetOf` cats2) &&  not (cats2 `subsetOf` cats1)
           then RuleOK 
           else XRuleErr r
      cats1 = catOfR ct r1
      cats2 = catOfR ct r2

chkR ct (Rop ST r1 r2)  = chkR ct r1 `errOR` chkR ct r2
chkR ct (Rop STN r1 r2) = chkR ct r1 `errOR` chkR ct r2


chkR ct r@(Rop UNION r1 r2) = chkR ct r1 `errOR` chkR ct r2 `errOR` e3
      where
      e3 = if   cats1 `subsetOf` cats2
             && cats2 `subsetOf` cats1
           then RuleOK
           else XRuleErr r
      cats1 = catOfR ct r1
      cats2 = catOfR ct r2


chkR ct r@(Rop INTERSECT r1 r2) =  chkR ct r1 `errOR` chkR ct r2 `errOR` e3
      where
      e3 = if   cats1 `subsetOf` cats2
             && cats2 `subsetOf` cats1
           then RuleOK
           else XRuleErr r
      cats1 = catOfR ct r1
      cats2 = catOfR ct r2

chkR ct (Rop JOIN r1 r2) = chkR ct r1 `errOR` chkR ct r2


-- | To generate raw test suite from a Partition expression.
semRule :: CTree -> Rule -> Suite
semRule ctree pexp = worker . nnf $ pexp

   where

   worker (All c) = classes2suite c (classesOf ctree c)
   worker (Neg (All c)) = []
   worker (Include (ps@(p:_))) = classes2suite cn . concat . map (classesOf ctree) $ ps
      where
      cn = catOf_ ctree p

   worker (Neg (Include (ps@(p:_)))) = classes2suite cn classes2
      where
      cn = catOf_ ctree p
      classes1 = concat . map (classesOf ctree) $ ps
      classes2 = classesOf ctree cn `minus_` classes1

   worker (Andp c d) = worker c `product_` worker d
   worker (Andm c d) = worker c `sum_` worker d
   worker (Union c d) = worker c `union_` worker d
   worker (Intersect c d) = worker c `intersect_` worker d

-- Ruled Combinations

-- | Apply a combination rule on a classification tree to generate a suite. The generated suite
-- may however still be incomplete/invalid as they will only contain classes from categories constrained
-- by the rules. Since each test-case must cover ALL categories, later on we will have to 
-- extend the test-cases generated by this function with classes from the missing categories.

sem :: CTree -> XRule -> Suite
sem ct (Rule_ p) = semRule ct p
sem ct (Rop TIMES r s) = sem ct r `product_` sem ct s
sem ct (Rop PLUS r s)  = sem ct r `sum_` sem ct s
sem ct (Rop UNION r s) = sem ct r `union_` sem ct s
sem ct (Rop INTERSECT r s)  = sem ct r `intersect_` sem ct s
sem ct (Rop ST a b)    = filter ok suitea
   where
   suitea = sem ct a
   suiteb = sem ct b
   ok tca = any (\tcb-> tcb `subsetOf` tca) suiteb 
sem ct (Rop STN a b)    = filter ok suitea
   where
   suitea = sem ct a
   suiteb = sem ct b
   ok tca = not (any (\tcb-> tcb `subsetOf` tca) suiteb)

sem ct (Rop JOIN a b) = sJoin (sem ct a) (sem ct b)


-- find the categories which are not covered by a suite. Requires the 
-- suite to be well-formed.
findMissing :: CTree -> Suite -> CTree
findMissing ct [] = ct
findMissing ct (s:_) = filter p ct
    where
    usedCategories = map (\(C_ c _)-> c) s
    p (Cat cn _)   = cn `notElem` usedCategories

-- | This calls the function semantic, and fills the missing parts of its output such
-- that the remaining categories are miminally covered.
minRuledComb :: CTree -> XRule -> Suite
minRuledComb ct rule = 
   if null missingCats then rawsuite else rawsuite `sum_` minComb missingCats
   where
   rawsuite    = sem ct rule
   missingCats = findMissing ct rawsuite


-- | This calls the function semantic, and fills the missing parts of its output such
-- that the remaining categories are fully covered.
fullRuledComb :: CTree -> XRule -> Suite
fullRuledComb ct rule = 
   if null missingCats then rawsuite else rawsuite `product_` fullComb missingCats
   where
   rawsuite    = sem ct rule
   missingCats = findMissing ct rawsuite

-- ================================================
--Some auxiliary functions
-- ================================================

-- A variant of zipWith, but will repeat the shortest list, unless it is empty, to make it
-- equal length with the other list. This is the generic version of sum.
--
sumx op s t = worker s t
   where
   worker  _  [] = []
   worker [] _   = []
   worker s  t   = if length s >= length t then zipL s t else zipR s t
   zipL s t = zipWith op s (t ++ concat (repeat t))
   zipR s t = zipWith op (s ++ concat (repeat s)) t

-- | Produces raw minimal combination over members of two sets.
sum_ :: [[a]] -> [[a]] -> [[a]]
sum_ = sumx (++)

--
-- Generic version of product.
--
productx op s t = worker s t
   where
   worker _  []    = []
   worker [] _     = []  
   worker (x:s) t  =  map (op x) t  ++  worker s t

-- | Produces raw full combination over members of two sets.
product_ :: [[a]] -> [[a]] -> [[a]]
product_ = productx (++)

--
-- implementing the joint
--
sJoin :: Suite -> Suite -> Suite
sJoin [] _ = []
sJoin (h:t) x = union (sIntersect h x) (sJoin t x)

sIntersect :: TestCase -> Suite -> Suite
sIntersect _ [] = []
sIntersect x (h:t) = case (sMatch x h) of
		     Nothing -> sIntersect x t
		     Just a -> (a:(sIntersect x t))

sMatch :: TestCase -> TestCase -> Maybe TestCase
sMatch x y = matchAux x y [] where
	     matchAux [] [] a = Just a
	     matchAux a [] b = Just (a++b)
	     matchAux [] a b = Just (a++b)  -- hmm.. this is not symmetric, need patch??  ==> oh ok, a valid test-case should only contain one class per category.
	     matchAux (h:t) a b = if (elem h a) then matchAux t (delete h a) (h:b)
						else if (isCategory h a) then Nothing
									 else matchAux t a (h:b)
									
isCategory :: Class_ -> TestCase -> Bool
isCategory _ [] = False
isCategory (C_ a b) ((C_ c d):t) = if (a==c) then True else isCategory (C_ a b) t


-- just for test
ex1 :: CTree
ex1 = [ "Color" <== ["Red", "Blue", "Yellow", "Green", "Purple"] ,

        "Shape" <== leaves ["Circle"]
                    |++|
                    ["4side" <== ["Square", "Rectangle"]]
                    |++|
                    ["Triangle" <==  ["Isosceles", "Equilateral", "Scalene"]],

        "Size" <== ["Big","Small"],

        "Material" <== leaves ["Wood", "Plastic", "Rubber"] 
                       |++| 
                       ["Metal" <== ["Iron", "Steel"]],

        "Inside" <== ["Hollow", "Full"], 

        "Volume" <== leaves ["Pyramid","Sphere"] 
                     |++| 
                     ["Cube" <== ["Dice", "Rubik"]]

      ]