{- 

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 CTy.TCgen where

import Data.List
import Data.Maybe
import CTy.CRule
import CTy.Utils


--Minimal Combination

-- | Generate a suite that minimally covers a classification tree. That is, such that
-- each class is covered at least once. 
minComb :: CTree c -> Suite c
minComb (ClsTree cats) = foldr1 rawMinProd . map getSingTestCases $ cats


-- | Generate a suite that consisting of all possible combinations induced by a classification
-- tree.
fullComb :: CTree c -> Suite c
fullComb (ClsTree cats) = foldr1 rawMaxProd . map getSingTestCases $ cats


-- 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.
--
zipW2 op s t = worker s t
   where
   worker [] [] = []
   worker [] v  = zipWith op ss v
   worker u  [] = zipWith op u  tt
   worker (x:u) (y:v) = op x y : worker u v
   ss = concat . repeat $ s
   tt = concat . repeat $ t

-- | Produces raw minimal combination over members of two sets.
rawMinProd = zipW2 (++)

-- | Raw full combination over members of two sets.
--
rawMaxProd s t = [ x ++ y |  x<-s, y<-t ]

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

-- | To check if a Rule is well-formed. Will return Nothing if the rule is ok,
-- | else it will return the (lowest level) conflicting rules.

chkR :: CTree c -> Rule -> [Rule]

chkR ct o@(All c)  = if c `elem` catNames ct then []
                     else [o]


chkR ct o@(Include ps) = 
      if not (null ps) && allValid && isMonoset then []
      else [o]
      where
      cats = map (catOf ct) ps
      -- all partitions in ps must exists in ct
      allValid  = all isJust cats
      -- ps must be a monoset
      isMonoset = isSing (nub cats)

chkR ct (Neg p) = chkR ct p

chkR ct o@(Andp p q) = if null epq then e3 else epq
      where
      epq = chkR ct p ++ chkR ct q 
      e3 = if    not (catsp `subsetOf` catsq)
             &&  not (catsq `subsetOf` catsp)
           then []
           else [o]
      catsp = catsInRule ct p
      catsq = catsInRule ct q

chkR ct o@(Andm p q) = if null epq then e3 else epq
      where
      epq = chkR ct p ++ chkR ct q 
      e3 = if    not (catsp `subsetOf` catsq)
             &&  not (catsq `subsetOf` catsp)
           then []
           else [o]
      catsp = catsInRule ct p
      catsq = catsInRule ct q

chkR ct o@(Union p q) = if null epq then e3 else epq
      where
      epq = chkR ct p ++ chkR ct q 
      e3 = if (catsp `subsetOf` catsq)
              &&  (catsq `subsetOf` catsp)
           then []
           else [o]
      catsp = catsInRule ct p
      catsq = catsInRule ct q

chkR ct o@(Intersect p q) = if null epq then e3 else epq
      where
      epq = chkR ct p ++ chkR ct q 
      e3 = if (catsp `subsetOf` catsq)
              &&  (catsq `subsetOf` catsp)
           then []
           else [o]
      catsp = catsInRule ct p
      catsq = catsInRule ct q


-- | 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 (orFull_ (Neg p) (Neg q))
nnf (Neg (Andm p q)) = nnf (orMin_ (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

orFull_  p q  =  (p `Andp` q) `Union` ((p `Andp` Neg q) `Union` (Neg p `Andp` q))
orMin_   p q  =  (p `Andm` q) `Union` ((p `Andm` Neg q) `Union` (Neg p `Andm` q))

s `subsetOf` t   = all (\x-> x `elem` t) s

--
-- | union of two suites over the same categories
--
st1 `union_` st2 = filter (not . occur) st1 ++ st2
   where
   occur tc1 = any (\tc2-> (tc1 `covers` tc2) && (tc2 `covers` tc1)) st2

-- | intersection of two suites over the same categories
--
st1 `intersect_` st2 = filter occur st1
   where
   occur tc1 = any (\tc2-> (tc1 `covers` tc2) && (tc2 `covers` tc1)) st2

-- | subset of st1 consisting of test-cases that can cover some test-case
-- in st2.
st1 `suchthat_` st2 = filter occur st1
   where
   occur tc1 = any (\tc2-> tc1 `covers` tc2) st2

-- | subset of st1 consisting of test-cases that does not cover some test-case
-- in st2.
st1 `except_` st2 = filter (not . occur) st1
   where
   occur tc1 = any (\tc2-> tc1 `covers` tc2) st2

-- | To interpret a combination rule, to generate a test suite. The test-cases
-- in the suite may still be partial and have to be padded to make them complete.
semRule :: CTree tv -> Rule -> Suite tv
semRule ctree rule = worker . nnf $ rule

   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 = map fst . concat . map (classesOf ctree) $ ps
      classes2 = filter ok (classesOf ctree cn)
      ok (cname,tv) = cname `notElem` classes1

   worker (Andp c d) = worker c `rawMaxProd` worker d
   worker (Andm c d) = worker c `rawMinProd` worker d
   worker (Union c d) = worker c `union_` worker d
   worker (Intersect c d) = worker c `intersect_` worker d


-- Find the categories which are not covered by a suite. Requires the 
-- suite to be well-formed.
findMissing :: CTree tv -> Suite tv -> [Category tv]
findMissing (ClsTree cats) suite = filter (not . occurIn suite) cats
   where
   occurIn [] _ = False
   occurIn (tc:_) (Cat cn _) = cn `elem` map (\(n,_,_)->n) tc


-- | Given a test suite consisting of partial test-cases, this will pad
-- the test-cases to make the complete. Categories which are still missing
-- in those test-cases will only be minimally combined. 
minPadding :: CTree tv -> Suite tv -> Suite tv
minPadding ct [] = []
minPadding ct suite = 
   if null missingCats
      then suite 
      else suite `rawMinProd` padding 
   where
   missingCats = findMissing ct suite
   padding = minComb (ClsTree missingCats)

-- | The same as the other padding, except the categories which are 
-- still missing will be fully combined. 
fullPadding :: CTree tv -> Suite tv -> Suite tv
fullPadding ct [] = []
fullPadding ct suite = 
   if null missingCats
      then suite
      else suite `rawMaxProd` padding
   where
   missingCats = findMissing ct suite
   padding = fullComb (ClsTree missingCats)



-- | The "relational-joint" operator on suites.

sJoin :: Suite tv -> Suite tv -> Suite tv
sJoin [] _ = []
sJoin (t:suite1) suite2 = union_ (sIntersect t suite2) (sJoin suite1 suite2)

sIntersect :: TestCase tv -> Suite tv -> Suite tv
sIntersect _ [] = []
sIntersect s (t:suite) =
   case sMatch s t of
      Nothing -> sIntersect s suite
      Just a  -> a : sIntersect s suite



sMatch :: TestCase tv -> TestCase tv -> Maybe (TestCase tv)
sMatch s t = matchAux s t [] 
   where
   matchAux [] [] z = Just z
   matchAux s  [] z = Just (s++z)
   matchAux [] t  z = Just (t++z)  

   matchAux (c:s) t z = 
       if occur c t then matchAux s (delete c t) (c:z)
       else if (isCategory c t) then Nothing
       else matchAux s t (c:z)

   occur c tc  = any (clEqual c) tc
   delete c tc = filter (\d-> not(c `clEqual` d)) tc
	
   isCategory :: Class_ tv -> TestCase tv -> Bool
   isCategory _ [] = False
   isCategory c@(cn1,_,_) ((cn2,_,_):t) = (cn1==cn2) ||  isCategory c t


kwise_ op1 op2 k rules = zipWith op2 p1 p2
   where
   p1 = map (foldr1 op1) part1
   p2 = map (foldr1 op2) part2
   part1 = filter (\s-> length s == k) (subsequences rules)
   part2 = map fill part1
     where
     fill s = filter (\r-> r `notElem` s) rules

--
-- For producing k-wise combination over a given list of rules.
-- This will produce all subsets of the rules of size-k, the
-- rules there will be fully combined. And then each will be filled
-- with the rest of the still missing rules, and minimally combined.
--
kwise k rules = kwise_ (Andp) (Andm) k rules


--
--
exR0 = (Include ["old"] `Andp` Include ["super"])

exR1 = exR0 `Union` (Include ["adult"] `Andm` All "insType")

weight_ op f s = foldr1 op [ f tv | (_,_,tv) <- s ]

ssort_ :: Ord val => (val->val->val) -> (tv->val) -> Suite tv -> Suite tv
ssort_ op f suite = map fst (sortBy lessEq suite')
   where
   suite'  = [ (s, value s) | s <- suite ]
   value s = weight_ op f s
   -- value s = foldr1 op [ f tv | (_,_,tv) <- s ]
   (_,x) `lessEq` (_,y) =  compare x y

takeWhile_ :: (val->val->val) -> (tv->val) -> (val->Bool) -> Suite tv -> Suite tv
takeWhile_ op f pred suite = [ s | s <- suite, pred (weight_ op f s) ]

ptakeWhile_ :: (Float->Bool) -> Suite (tv,Float) -> Suite (tv,Float)
ptakeWhile_ = takeWhile_ (*) (\(tv,w)-> w)

wsort_ :: Suite (tv,Float) ->  Suite (tv,Float)
wsort_ = ssort_ (+) (\(tv,w)-> w)

psort_ :: Suite (tv,Float) ->  Suite (tv,Float)
psort_ = ssort_ (*) (\(tv,w)-> w)

--
-- to reorder the classes in test-cases to according to the classification
-- tree
--
fixorder_ ::CTree tv -> Suite tv ->  Suite tv
fixorder_ (ClsTree cats) suite = map reorder suite
  where
  reorder tc = f order
     where
     f []    = []
     f (c:s) = (fromJust . find (\(n,_,_)-> n==c) $ tc) : f s
  order = map (\(Cat name _)-> name) cats

strip suite = map f suite
   where
   f tc = map (\(_,c,tv)->(c,tv)) tc

strip2 suite = map f suite
   where
   f tc = map (\(_,c,(tv,_))->(c,tv)) tc