Exercises.hs

-----------------------------------------------------------------------------
-- Copyright 2020, Ideas project team. This file is distributed under the
-- terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
module Domain.Hypothesis.Exercises (hypothesisExercise) where

import Control.Monad
import qualified Data.Map as M
import Data.List
import Data.Maybe
import Domain.Math.Data.Relation
import Domain.Hypothesis.Examples
import Domain.Hypothesis.Constraints
import Domain.Hypothesis.BuggyRules
import Domain.Hypothesis.Rules
import Domain.Hypothesis.Strategies
import Domain.Statistics.ComponentSet
import Domain.Statistics.Parser
import Ideas.Common.Library  hiding (Predicate)
import Domain.Math.Expr.Data
import Ideas.Encoding.OpenMathSupport
import Ideas.Utils.Uniplate
import Ideas.Text.XML hiding (children)
import Prelude               hiding (until)

-- Debug functions
css :: [ComponentSet]
css = mapMaybe fromContext $ concatMap terms $
   mapMaybe (defaultDerivation hypothesisExercise) (examplesAsList hypothesisExercise)

_testPP :: IO ()
_testPP = forM_ css $ \x ->
   let s = prettyPrinter hypothesisExercise x in
   case parser hypothesisExercise s of
      Right y | x == y    -> putChar '.'
              | otherwise -> error $ show (x, y)
      Left msg -> error $ s ++ "\n" ++ msg

_testOM :: IO ()
_testOM = forM_ css $ \x ->
   case toOpenMath hypothesisExercise x of
      Right omobj ->
         case fromOpenMath hypothesisExercise omobj of
            Just y | x == y    -> putChar '.'
                   | otherwise -> error $ "Not the same:\n" ++ show x ++ "\n" ++ show y
            Nothing -> error $ show omobj
      Left msg -> error $ show x ++ "\n" ++ msg

_see :: Int -> IO ()
_see n = printDerivation hypothesisExercise (examplesAsList hypothesisExercise !! n)

_testje :: IO ()
_testje = printDerivation hypothesisExercise opgave_5_4

_save :: IO ()
_save = do
   let pilot = [("A", mayPilotA), ("B", mayPilotB), ("C", mayPilotC), ("D", mayPilotD)]
       ex = hypothesisExercise
   forM_ pilot $ \(n, cs) -> do
      writeFile ("Task" ++ n ++ ".txt") $ showDerivation ex cs
      writeFile ("Task" ++ n ++ "-OM.txt") $ showDerivationOM ex cs

showDerivationOM :: Exercise a -> a -> String
showDerivationOM ex a =
   case defaultDerivation ex a of
      Just d  -> show $ biMap fst f d
      Nothing -> "no derivation"
 where
   errorXML = makeXML "error" mempty
   f ctx = fromMaybe errorXML $ do
       x     <- fromContext ctx
       omobj <- toOpenMath ex x
       return (toXML omobj)

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

hypothesisExercise :: Exercise ComponentSet
hypothesisExercise = emptyExercise
   { exerciseId    = describe "Hypothesis testing" $ newId "hypothesis"
   , prettyPrinter = show
   , status        = Experimental
   , parser        = parseComponentSet
   , strategy      = liftToContext hypothesisStrategy
   , extraRules    = fmap liftToContext buggyRules
   , ruleOrdering  = ruleOrderingWith highPriorityRules
   , examples      = examplesWithDifficulty [ (Medium, cs) | cs <- opgavenSW ++ opgavenEconomie ]  -- hypothesisExamples
   , equivalence   = withoutContext eqComponentSet
   , similarity    = withoutContext similarComponentSet
   , constraints   = map liftToContext hypothesisConstraints
   , hasTypeable   = useTypeable
   , ready         = predicate (hasConclusionHypotheses <&&> checkConstraints)
   , hasTermView   = Just termView
   }
   
highPriorityRules :: [Rule ComponentSet]
highPriorityRules = 
   [ addHypothesesRule
   , lookupTValueRule, lookupZValueRule
   , computePValueTTest, computePValueZTest
   , addTestValueRule
   , hypothesesConclusionCriticalRule, hypothesesConclusionPValueRule
     -- buggy rules
   , buggyTValueSided, buggyTValueTestValue -- Sietske: higher priority than corresponding buggy alpha rule
   , buggyRValueSided, buggyRValueTestValue -- idem
   , buggyZValueSided, buggyZValueTestValue
   , buggyChiValueSided, buggyChiValueTestValue
   ]

----------------------------------------------------------
-- Equivalence
eqComponentSet :: ComponentSet -> ComponentSet -> Bool
eqComponentSet x y = compareIntials
                  && checkConstraints x
                  && checkConstraints y
 where
   compareIntials =
     M.fromList (toList (initials x)) == M.fromList (toList (initials y))

checkConstraints :: ComponentSet -> Bool
checkConstraints cs =
   all (`checkConstraint` cs) hypothesisConstraints
   
checkConstraint :: Constraint ComponentSet -> ComponentSet -> Bool
checkConstraint p cs 
   | not (isRelevant p cs) = True
   | otherwise = isSatisfied p cs

----------------------------------------------------------
-- Similarity

-- To do: not all component ids compare doubles with the same precision
-- (e.g. pvalue uses 3 decimals, default is 2)
similarComponentSet :: ComponentSet -> ComponentSet -> Bool
similarComponentSet cs1 cs2 = sorted cs1 `eqList` sorted cs2
 where
   sorted = map f . sortOn fst . toList
    where
      f (n, CExpr e)     = (n, CExpr (normalizeExpr e))
      f (n, CRelation r) = (n, CRelation (fmap normalizeExpr r))
      f (n, c)           = (n, c)
   
   eqList :: [(ComponentId, Component)] -> [(ComponentId, Component)] -> Bool
   eqList xs ys = length xs == length ys && all (\((a, x), (b, y)) -> a == b && x `eqComponent` y) (zip xs ys)

   eqComponent :: Component -> Component -> Bool
   eqComponent (CExpr x) (CExpr y) = eqExpr x y
   eqComponent (CRelation x) (CRelation y) = 
      eqExpr (leftHandSide x) (leftHandSide y) && eqExpr (rightHandSide x) (rightHandSide y)
         && relationType x == relationType y
   eqComponent x y = x == y
   
   eqExprs :: [Expr] -> [Expr] -> Bool
   eqExprs [] [] = True
   eqExprs (x:xs) (y:ys) = eqExpr x y && eqExprs xs ys
   eqExprs _ _ = False
   
   eqExpr :: Expr -> Expr -> Bool
   eqExpr (Number x) (Number y) = equalDouble x y
   eqExpr x y = 
      case (getFunction x, getFunction y) of 
         (Just (f, xs), Just (g, ys)) -> f == g && xs `eqExprs` ys
         _ -> x == y


-- we vouwen hier de definities uit zodat we formules kunnen herkennen
-- afronden op 2 decimalen: beter is om expressies component-gewijs te 
-- vergelijken en daarbij de hulpfunctie 'equal' te gebruiken
normalizeExpr :: Expr -> Expr
normalizeExpr (Var "sigmaM") = Var "sigma" / sqrt (Var "n")
normalizeExpr (Var "SEM") = Var "s" / sqrt (Var "n")
normalizeExpr (Nat n)     = Number (fromInteger n)
normalizeExpr expr = descend normalizeExpr expr

-- | Test whether the conclusionhypothesis is present in the componentset. If
-- the predicate holds then he exercise is considered /done/.
hasConclusionHypotheses :: ComponentSet -> Bool
hasConclusionHypotheses cs = contains cs ConclusionHypotheses