{-# LANGUAGE TupleSections, FlexibleInstances #-}
-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me 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.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-----------------------------------------------------------------------------

module Task.AreaOfATriangle (areaOfATriangle) where

import Control.Applicative
import Control.Monad
import Data.List
import Data.Semigroup
import Domain.Math.Expr
import Ideas.Common.Library hiding ((|>), steps, parser, recognizer)
import Recognize.Data.MathParserOptions
import Recognize.Parsing.Derived
import Recognize.Data.Math
import Util.Expr
import Data.Bool
import Recognize.Data.Approach (Approach (Algebraic, Arithmetic))
import Recognize.Data.Attribute
import Recognize.Data.MathStoryProblem
import Recognize.Data.MathParserOutput
import Recognize.Data.Diagnosis
import Recognize.Data.StringLexer
import Recognize.Data.StringLexerOptions
import Recognize.Expr.Normalform
import Recognize.Parsing.Interpretation
import Recognize.Parsing.Parse
import Recognize.Recognizer
import Bayes.Evidence
import Recognize.Data.Step
import Bayes.Network
import Task.Network.AreaOfATriangle

areaOfATriangle :: MathStoryProblem
areaOfATriangle = mathStoryProblem
   { problemId  = newId "areaofatriangle"
   , analyzers  = [ (newId "09a", ana9a)
                  , (newId "09b", ana9b)
                  , (newId "09c", ana9c)
                  ]
   , inputFile   = Just "input/areaofatriangle.csv"
   , networkFile = Just "networks/AreaOfATriangle.xdsl"
   , singleNetwork = network
   }
 where
   ana = analyzer
      { lexer  = stringLexer stringLexerOptions {variableWhitelist = concatMap permutations ["abc","ab","bc","ac","bdef","cd","bf","de","fe"]}
      , parser = mathParser mathParserOptions {multByConcatenation = False,convertToLowercase = True} . stringLexerOutput
      }
   ana9a = ana
      { recognizer = defaultRecognizer (pDiagnose pTaskQ1) . mathParserOutput
      , collector  = evidenceOfAbsence ans1 False .
           (\d -> makeAnswer ans1 ["Q1.S1"] d
            <> mconcat (map assessStep1 (steps d)))
      }
   ana9b = ana
      { recognizer = defaultRecognizer (pDiagnose pTaskQ2) . mathParserOutput
      , collector  = evidenceOfAbsence ans2 False .
            (\d -> makeAnswer ans2 ["Q2.S1"] d
            <> mconcat (map assessStep2 (steps d)))
      }
   ana9c = ana
      { recognizer = defaultRecognizer (pDiagnose pTaskQ3) . mathParserOutput
      , collector  = evidenceOfAbsence ans3 False .
            (\d -> makeAnswer ans3 ["Q3.A3","Q3.S3"] d
            <> ans3Strat .==  bool "Algebraic" "Numeric" (any ((`elem` [newId "Q3.A1", newId "Q3.A2", newId "Q3.A3"]) . getId) (steps d))
            <> mconcat (map assessStep3 (steps d)))
      }

makeAnswer :: IsId a => Node Bool -> [a] -> Diagnosis -> Evidence
makeAnswer s fs d = s .== ind
 where
   ind = any (\stp -> let atts = snd (getValue stp)
                             in
                             --elem Normalized atts && -- the final answer is
                             --still correct even if it is not normalized
                                getId stp `elem` map newId fs
                             && not (any (liftM2 (||) isMistake isApproximation) atts)) (steps d)

assessStep1 :: Step -> Evidence
assessStep1 s
   | getId s == newId "Q1.S1" = step .== Just stepCorrect
   | otherwise = mempty
 where
   stepCorrect = not (hasMistakes s)
   step | Normalized `elem` snd (getValue s) = ans1Strat1Step2
        | otherwise = ans1Strat1Step1


assessStep2 :: Step -> Evidence
assessStep2 s
   | getId s == newId "Q2.S1" = mconcat (map (.== Just stepCorrect) step)
   | otherwise = mempty
 where
   stepCorrect = not (hasMistakes s)
   step | Normalized `elem` snd (getValue s) = [ans2Strat1Step1, ans2Strat1Step2]
        | otherwise = [ans2Strat1Step1]

assessStep3 :: Step -> Evidence
assessStep3 s
   | getId s == newId "Q3.S1" =
        ans3Strat1Step1 .== Just stepCorrect
   | getId s == newId "Q3.S2" =
        ans3Strat1Step2 .== Just stepCorrect
   | getId s == newId "Q3.S3" =
        ans3Strat1Step3 .== Just stepCorrect
   | getId s == newId "Q3.A1" =
        ans3Strat2Step1 .== Just stepCorrect
   | getId s == newId "Q3.A2" =
        ans3Strat2Step2 .== Just stepCorrect
   | getId s == newId "Q3.A3" =
        ans3Strat2Step3 .== Just stepCorrect
   | otherwise =
        mempty
 where
   stepCorrect = not (hasMistakes s)

ab :: Interpretation
ab = interpret 10 <|> interpret (Var "ab")

x :: Interpretation
x =  interpret (Var "a")
 <|>  interpret (Var "x") -- old variable name
 <|> interpret (Var "bc") <! Sloppiness  -- exercise explicitly requires answer in terms of x.

abc :: Interpretation
abc = (ab >*< x
   <|> ab >+< x <! OperatorMixedUp plusSymbol timesSymbol <! Other "M6"
      ) >>/<< interpret 2
  <|> ab >*< x <! Misconception Rectangle Triangle <! Other "M2"
  <|> (ab >+< x) >*< interpret 2 <! Misconception Perimeter Area <! Other "M3"
  <|> ((ab >+< x
  <|> ab >^< interpret 2 >+< x >^< interpret 2) >^< (interpret 1 >/< interpret 2)) >^< interpret 2 <! Misconception Perimeter Area <! Other "M4"
  <|> ((ab >*< x) >/< interpret 2) >^< interpret 3 <! Misconception Volume Area <! Other "M5"

pTaskQ1 :: InterpretationParser (Approach,[Step])
pTaskQ1 = (Algebraic,) <$> many' (pSomewhere $
           pNamedStep (newId "Q1.S1") (interpret $ wildcard "abc") abc
        |> withModulo nf (pNamedStep (newId "Q1.S1") (interpret $ wildcard "abc") (first sqrt <$> (interpret 10 >^< interpret 2 >+< x >^< interpret 2)))
          )
        |> (Arithmetic,) <$> pQ3Arithmetic

bf :: Interpretation
bf = interpret 2 <|> interpret (Var "bf")

cd :: Interpretation
cd = interpret 3 <|> interpret (Var "cd")

bdef :: Interpretation
bdef = bf >>*<< (x >>+<< cd)
   <|> bf >*< x >*< cd <! OperatorMixedUp plusSymbol timesSymbol <! Other "M3"
   <|> (bf >+< cd >+< x) >*< interpret 2 <! Misconception Perimeter Area <! Other "M4"
   <|> bf >+< cd >+< x <! Misconception HalfPerimeter Area <! Other "M5"
   <|> (interpret 5 >*< x <! IncorrectDistribution <! Other "M7")

pTaskQ2 :: InterpretationParser [Step]
pTaskQ2 = pAnyOf [pNamedStep (newId "Q2.S1") (interpret $ wildcard "bdef") bdef]

pTaskQ3 :: InterpretationParser (Approach, [Step])
pTaskQ3 = (,) Algebraic <$> pQ3Algebraic
       |> (,) Arithmetic <$> pQ3Arithmetic

pQ3Arithmetic :: InterpretationParser [Step]
pQ3Arithmetic = pAnyOf
                [ pStepEq (newId "Q3.A1") (interpret 5 >>*<< interpret (wildcard "x")) ((interpret 2 >*< interpret (wildcard "x")) >+< interpret 6)
                , pStepStrongIneq' (newId "Q3.A1") (interpret 5 >>*<< interpret (wildcard "x")) ((interpret 2 >*< interpret (wildcard "x")) >+< interpret 6)

                , pStepEq (newId "Q3.A2") (interpret 5 >>*<< interpret 2) ((interpret 2 >*< interpret 2) >+< interpret 6)
                , pStepStrongIneq' (newId "Q3.A2") (interpret 5 >>*<< interpret 2) ((interpret 2 >*< interpret 2) >+< interpret 6)

                , pNamedStep (newId "Q3.A3") (interpret $ wildcard "ans") (interpret 2)
                ]
                -- divide both sides by 10: 0.5x*10=2x+6 0.5x=0.2x+0.6 0.3x=0.6 x=2

pQ3Algebraic :: InterpretationParser [Step]
pQ3Algebraic = inLiberalEquationMode $ withModulo nfComAssoc $ pAnyOf
        [ pStepEq (newId "Q3.S1") (interpret 5 >>*<< x) (interpret 2 >>*<< x >>+<< (interpret 2 >>*<< interpret 3 <|> interpret 6))
        , pStepEq (newId "Q3.S2") (interpret 3 >>*<< x) (interpret 6)
        , pStepEq (newId "Q3.S3") x (interpret 2)
        ]
     |> (:[]) <$> pStepEq (newId "Q3.S1") abc bdef

class DiagnoseParser a where
  getApproach :: a -> Approach
  getSteps :: a -> [Step]

instance DiagnoseParser [Step] where
  getApproach _ = Algebraic
  getSteps = id

instance DiagnoseParser (Approach,[Step]) where
   getApproach (a, _) = a
   getSteps    (_, a) = a

pDiagnose :: DiagnoseParser a => InterpretationParser a -> InterpretationParser Diagnosis
pDiagnose p = do addWildcardConstraint "x" isLiteral
                 addWildcardConstraint "def" isVariable
                 z <- p
                 guard (not . Prelude.null . getSteps $ z)
                 return $ newDiagnosis (getApproach z) (getSteps z)