Tests.hs

-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
-- under the terms of the GNU General Public License. For more information, 
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-----------------------------------------------------------------------------
module Domain.Math.Polynomial.Tests (tests) where

import Common.TestSuite
import Common.View
import Domain.Math.Polynomial.Generators
import Domain.Math.Polynomial.Views
import Domain.Math.Numeric.Views
import Domain.Math.Numeric.Laws
import Test.QuickCheck

------------------------------------------------------------
-- Testing instances

tests :: TestSuite
tests = do 
   let v = viewEquivalent (polyViewWith rationalView)
   testNumLawsWith v "polynomial" (sized polynomialGen)

-- see the derivations for the DWO exercise set
{-
seeLE  n = printDerivation linearExercise $ concat linearEquations !! (n-1)
seeQE  n = printDerivation quadraticExercise $ orList $ return $ build equationView $ concat quadraticEquations !! (n-1)
seeHDE n = printDerivation higherDegreeExercise $ orList $ return $ build equationView $ higherDegreeEquations !! (n-1)

-- test strategies with DWO exercise set
{-
testLE  = concat $ zipWith (f linearExercise)       [1..] $ concat linearEquations
testQE  = concat $ zipWith (f quadraticExercise)    [1..] $ map (orList . return . build equationView) $ concat quadraticEquations
testHDE = concat $ zipWith (f higherDegreeExercise) [1..] $ map (orList . return . build equationView) higherDegreeEquations
-}
f :: (Show b, Show a) => Exercise a -> b -> a -> [b]
f s n e = map p (g (applyAll (strategy s) (inContext s e))) where
  g xs | null xs   = error $ show n ++ ": " ++ show e
       | otherwise = xs
  p a  | maybe False (isReady s) (fromContext a) = n
       | otherwise = error $ show n ++ ": " ++ show e ++ "  =>  " ++ maybe "??" show (fromContext a)
       
randomLE = quickCheck $ forAll (liftM2 (:==:) (sized linearGen) (sized linearGen)) $ \eq -> 
   (>0) (sum (take 10 $ f linearExercise 1 eq))
randomQE = quickCheck $ forAll (liftM2 (:==:) (sized quadraticGen) (sized quadraticGen)) $ \eq -> 
   (>0) (sum (take 10 $ f quadraticExercise 1 (orList [build equationView eq])))

{-
eqLE = concat $ zipWith (g linearExercise) [1..] $ concat linearEquations  
eqQE = concat $ zipWith (g quadraticExercise) [1..] $ map (orList . return) $ concat quadraticEquations
eqHDE = concat $ zipWith (g higherDegreeExercise) [1..] $ map (orList . return) higherDegreeEquations

g s n e = map p (h (derivations (derivationTree (strategy s) (inContext e)))) where
  h xs | null xs   = error $ show n ++ ": " ++ show e
       | otherwise = xs
  p (a, xs) = case [ (x, y) | x <- ys, y <- ys, Prelude.not (equivalence s x y) ] of
                 [] -> let l = length xs in l*l
                 (x, y):_ -> error $ show n ++ ": " ++ show x ++ "   is not   " ++ show y
   where ys = map fromContext (a : map snd xs)
-}
   
-- e1 = match higherDegreeEquationsView $ OrList [(x :==: 2)] where x = Var "x"
-- e2 = simplify rationalView (Sqrt ())

-- goLE = eqTest ineqLinearExercise
goQE = eqTest ineqQuadraticExercise

--eqTest :: Exercise a -> IO ()
eqTest ex =
   forM_ (examples ex) $ \eq -> do
      let tree  = derivationTree (strategy ex) (inContext ex eq)
      forM_ (derivations tree) $ \d -> do
         let xs = terms d
             pp = maybe "??" (prettyPrinter ex) . fromContext
         forM [ (a, b) | a <- xs, b <- xs ] $ \(a, b) ->
            if equalityIneq a b -- equivalence ex (fromContext a) (fromContext b)
             then putChar '.' 
             else error $ unlines ["", pp a, pp b]

equalityIneq :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool
equalityIneq ca cb = fromMaybe False $
   liftM2 (equivalence ineqQuadraticExercise) (f ca) (f cb)
 where
   f = fmap g . fromContext
   g | any clipboardHasIneq [ca,cb] = turnIntoEqualTo
     | otherwise                    = id

clipboardHasIneq :: Context a -> Bool
clipboardHasIneq = isJust . evalCM (\_ -> lookupClipboard "ineq")

turnIntoEqualTo :: Logic (Relation a) -> Logic (Relation a)
turnIntoEqualTo = g . fmap (\rel -> 
   leftHandSide rel .==. rightHandSide rel)
 where
   -- temporary fix
   g (p :&&: q) = g p :&&: g q
   g (p :||: q) = g p :||: g q
   g p          = p -}