{- 

Author: Joao Amorim, Wishnu Prasetya

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 Sequenic.CTy.Types
-- import InputFigures

--Counts

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

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

-- | To count the number of classes in a classification tree.
nClasses :: Input -> 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. 
minimalComb :: Input -> Suite
minimalComb [] = []
minimalComb ((Cat s x):t) = mC (map (\y -> [R s y]) (getClasses (Cat s x))) (minimalComb t)


-- | Generate a suite that consisting of all possible combinations induced by a classification
-- tree.
fullComb :: Input -> Suite
fullComb [] = []
fullComb ((Cat s x):t) = fC (map (\y -> [R s y]) (getClasses (Cat s x))) (fullComb t)


--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, we will have to extend the test-cases
-- generated by this function with classes from the missing categories.

semantic :: Rule -> Input -> Suite
-- all classes beneath these partitions:
semantic (P s) x = fClasses s x
-- all classes (of the same category), which are NOT under these partitions:
semantic (NotP s) x = fNotClasses s x
-- all classes of these category:
semantic (Ctg s) x = fGetClasses s x
-- produce minimal combination:
semantic (Rop Plus a b) x = mC (semantic a x) (semantic b x)
-- form a cartesian products of the test-cases in both suite:
semantic (Rop Times a b) x = fC (semantic a x) (semantic b x)
-- union of both suites:
semantic (Rop Union a b) x = union (semantic a x) (semantic b x)
-- relational-like joint of two suite:
semantic (Rop Join a b) x = sJoin (semantic a x) (semantic b x)
-- intersection of two suites:
semantic (Rop Intersect a b) x = intersect (semantic a x) (semantic b x)
-- 
semantic (Rop ST a b) x = onlyComb (semantic a x) (semantic b x)
semantic (Rop STN a b) x = exceptComb (semantic a x) (semantic b x)
semantic (RLog And a b) x = semantic (Rop Times (P a) (P b)) x
semantic (RLog Or a b) x = semantic (Rop STN (Rop Times (Ctg (getCat (head a) x)) (Ctg (getCat (head b) x))) (Rop Times (NotP a) (NotP b))) x
semantic (RLog Xor a b) x = (semantic (Rop Times (P a) (NotP b)) x)++(semantic (Rop Times (P b) (NotP a)) x) 
semantic (RLog Nor a b) x = semantic (Rop Times (NotP a) (NotP b)) x
semantic (RLog Equi a b) x = (semantic (Rop Times (P a) (P b)) x)++(semantic (Rop Times (NotP a) (NotP b)) x)
semantic (RLog Impl a b) x = (semantic (Rop Times (NotP a) (Ctg (getCat (head b) x))) x)++(semantic (Rop Times (P a) (P b)) x)

minComplete :: Input -> Suite -> Suite
minComplete a b = let x = findMissing a b
	       in minCompAux x b a

-- | This calls the function semantic, and fills the missing parts of its output such
-- that the remaining categories are miminally covered.
minRuledComb :: Rule -> Input -> Suite
minRuledComb a b = minComplete b (semantic a b)

fullComplete :: Input -> Suite -> Suite
fullComplete a b = let x = findMissing a b
	       in fullCompAux x b a

-- | This calls the function semantic, and fills the missing parts of its output such
-- that the remaining categories are fully covered.
fullRuledComb :: Rule -> Input -> Suite
fullRuledComb a b = fullComplete b (semantic a b)


--Some auxiliar functions


getClasses :: Category -> [Class]
getClasses (Cat s x) = concat (map classes x)

classes :: Partition -> [Class]
classes (Leaf c) = [c]
classes (Node s x) = concat (map classes x)

fC :: Suite -> Suite -> Suite
-- org: fC x [] = x   ???, patched by WP:
fC _ [] = []
fC [] _ = []  
fC (x:xs) y = (map (\a -> x++a) y)++(fC xs y)

mC :: Suite -> Suite -> Suite
mC x [] = x
mC [] y = y
mC x y = if ((length x) >= (length y)) then (auxmC x y) else (auxmC y x)

auxmC :: Suite -> Suite -> Suite
auxmC [] _ = []
auxmC _ [] = []
auxmC (x:xs) (y:ys) = ((x++y):(auxmC xs (ys++[y])))

fClasses :: [String] -> Input -> Suite
fClasses _ [] = []
fClasses s ((Cat x y):t) = (fAux s x y)++(fClasses s t)

fAux :: [String] -> String -> [Partition] -> Suite
fAux _ _ [] = []
fAux x y ((Node s l):t) = if (elem s x) then (map (\z -> [R y z]) (concat (map classes l)))++(fAux x y t)
				    else (fAux x y t)++(fAux x y l)
fAux x y ((Leaf s):t) = if (elem s x) then ([[(R y s)]])++(fAux x y t)
				  else fAux x y t

fNotClasses :: [String] -> Input -> Suite
fNotClasses a b = let s = getCat (head a) b
		  in fNaux a b s

fNaux :: [String] -> Input -> String -> Suite
fNaux _ [] _ = []
fNaux a ((Cat x y):t) b = if (b==x) then fNaux2 a y b else fNaux a t b

fNaux2 :: [String] -> [Partition] -> String -> Suite
fNaux2 _ [] _ = []
fNaux2 s ((Node a b):t) x = if (elem a s) then fNaux2 s t x
					  else (map (\z -> [R x z]) (classes (Node a b)))++(fNaux2 s t x)
fNaux2 s ((Leaf a):t) x = if (elem a s) then fNaux2 s t x
					else ([[R x a]])++(fNaux2 s t x)

fGetClasses :: String -> Input -> Suite
fGetClasses _ [] = []
fGetClasses s ((Cat x y):t) = if (s==x) then (map (\z -> [R s z]) (getClasses (Cat x y))) else fGetClasses s t

getCat :: String -> Input -> String
getCat _ [] = ""
getCat s ((Cat a b):t) = if (findP s b) then a else getCat s t

findP :: String -> [Partition] -> Bool
findP _ [] = False
findP s ((Node a b):t) = (s==a) || (findP s b) || (findP s t)
findP s ((Leaf x):t) = (s==x) || (findP s t)

findMissing :: Input -> Suite -> [String]
findMissing [] _ = []
findMissing ((Cat s _):cats) (h:t) = if (notExist s h) then (s:(findMissing cats (h:t))) 
						       else (findMissing cats (h:t))

notExist :: String -> Combination -> Bool
notExist _ [] = True
notExist s ((R a _):t) = if (s==a) then False 
				   else (notExist s t)

minCompAux :: [String] -> Suite -> Input -> Suite
minCompAux [] x _ = x
minCompAux (h:t) x i = minCompAux t (mC x (fGetClasses h i)) i

fullCompAux :: [String] -> Suite -> Input -> Suite
fullCompAux [] x _ = x
fullCompAux (h:t) x i = fullCompAux t (fC x (fGetClasses h i)) i

onlyComb :: Suite -> Suite -> Suite
onlyComb [] _ = []
onlyComb (h:t) x = if (coversComb h x) then (h:(onlyComb t x)) else onlyComb t x

exceptComb :: Suite -> Suite -> Suite
exceptComb [] _ = []
exceptComb (h:t) x = if (coversComb h x) then (exceptComb t x) else (h:(exceptComb t x))

covers :: Combination -> Combination -> Bool
covers _ [] = True
covers x (h:t) = (elem h x) && (covers x t)

coversComb :: Combination -> Suite -> Bool
coversComb _ [] = False
coversComb x (h:t) = if (covers x h) then True else coversComb x t

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


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

sMatch :: Combination -> Combination -> Maybe Combination
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 :: Result -> Combination -> Bool
isCategory _ [] = False
isCategory (R a b) ((R c d):t) = if (a==c) then True else isCategory (R a b) t