-----------------------------------------------------------------------------
-- 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.VPattern.Recognizer (vPattern) where

import Control.Applicative                     (many)
import Control.Arrow                           (second)
import Control.Monad                           (guard, msum)
import Util.List
import Util.Monad
import Recognize.Data.Approach
import Recognize.Data.Attribute hiding (Other)
import Recognize.Data.Math
import Recognize.Data.MathStoryProblem
import Recognize.Data.MathParserOptions
import Recognize.Data.MathParserOutput
import Recognize.Data.Diagnosis
import Recognize.Data.Step
import Recognize.Data.StringLexer
import Recognize.Expr.Functions
import Recognize.Expr.Normalform
import Recognize.Parsing.Derived
import Recognize.Parsing.Parse
import Recognize.SubExpr.SEParser
import Recognize.Recognizer
import Recognize.SubExpr.Recognizer
import Recognize.SubExpr.Symbols
import Task.VPattern.Assess
import Domain.Math.Data.Relation
import Domain.Math.Expr.Data
import Ideas.Common.Id
import Task.Network.VPattern
import Bayes.Evidence ( evidenceOfAbsence )

vPattern :: MathStoryProblem
vPattern = mathStoryProblem
   { problemId   = newId "vpattern"
   , analyzers   = [(newId "10", ana)]
   , inputFile   = Just "input/vpattern.csv"
   , networkFile = Just "networks/VPattern.xdsl"
   , singleNetwork = network
   }
 where
   ana = analyzer
      { parser     = mathParser mathParserOptions { functionCallWhitelist = "nN" } . stringLexerOutput
      , recognizer = seRecognizer pDiagnosis . mathParserOutput
      , collector  = evidenceOfAbsence ans1 False . assess'
      }

pDiagnosis :: SEParser Diagnosis
pDiagnosis = do
  (appr, e, st) <- pSteps
  let sd = newDiagnosis appr st
      -- exprs = rights (map (getResult . getMath) st)
      -- exprAsString = concatMap show exprs
  return $ sd { result = Just e }

pSteps :: SEParser (Approach, Expr, [Step])
pSteps = do
  (app,e,st) <- choice'
    [
      (\(e,st) -> (Algebraic,e,st)) <$> withGuard (not . null . snd) pStepsA1
    , (\(e,st) -> (Other "Algebraic2",e,st)) <$> withGuard ((>=2) . length . snd) pStepsA2
    , (\(e,st) -> (Other "Algebraic3",e,st)) <$> withGuard (not . null . snd) pStepsA3
    , (\(e,st) -> (Other "Algebraic4",e,st)) <$> withGuard ((>=2) . length . snd) pStepsA4
    ]
  _ <- many skip
  return (app,e,st)

{-
1 R
N = 1 + 2R
-}
stepS :: SEParser (Expr, [Step])
stepS = do
  (e,st) <- pMatchSubSteps sexpr
  return (e, appLast (addAttribute (FinalAnswer e)) st)
  where
    sexpr = lbl "S" $ lt "n" newMagicVar $ \x -> noSim $ 1 + 2 * x <!> 2 * x - 1 <!> newMagicNat * x <!> x + x + x

pStepsS :: SEParser (Expr, [Step])
pStepsS = (\(x, y, _) -> (x, y)) <$> pInOrder [const stepS]

{-
R (R+1)
N = R + (R + 1)
N = 2R + 1
-}
pStepsA1 :: SEParser (Expr, [Step])
pStepsA1 = (\(x, y, _) -> (x, y)) <$> pInOrder
  [ const $ pMatchSubSteps aexpr
  , const stepS
  ]
  where
    aexpr = lbl "A1" $ lt "n" newMagicVar $ \x -> noSim $ x + x + 1 <!> x + x - 1

{-
R (R+1)
N = R + (R + 1)
N = 2R + 1
-}
pStepsA2 :: SEParser (Expr, [Step])
pStepsA2 = (\(x, y, _) -> (x, y)) <$> pInOrder
  [ const $ pMatchSubSteps aexpr
  , const stepS
  ]
  where
    aexpr = lbl "A2" $ lt "n" newMagicVar $ \x -> noSim $ x + (x + 1) <!> x + (x - 1)

{-
2 3

R = 1 N = 2
R = 2 N = 3
N = 3 + 2*(R-1)
N = 3 + 2*R - 2
N = 1 + 2*R
-}
pStepsA3 :: SEParser (Expr, [Step])
pStepsA3 = (\(x, y, _) -> (x, y)) <$> pInOrder
  [ const $ pMatchSubSteps a1expr
  , const $ pMatchSubSteps a2expr
  , const stepS
  ]
  where
    a1expr = lbl "A3_1" $ lt "n" newMagicVar $ \x -> noSim $ 2*(x - 1 <!> x)
    a2expr = lbl "A3_2" $ lt "n" newMagicVar $ \x -> noSim $ 3 + 2*(x - 1 <!> x) <!> 2 + 3*(x-1 <!> x)

pStepsA4 :: SEParser (Expr, [Step])
pStepsA4 = (\(x, y, _) -> (x, y)) <$> pInOrder
  [ const $ second (maybe [] ((:[]) . addAttribute (Label "2")) . mergeSteps) <$> withGuard (\t -> length (snd t) >= 2) (pNumSteps 3)
  , const stepS
  ]

pNumSteps :: Expr -> SEParser (Expr, [Step])
pNumSteps e =
  choice'
    [ do
      (e',ss) <- pNumStep e
      pLog ("successfully parsed a num and value: " ++ show e' ++ " " ++ show ss)
      second (ss:) <$> pNumSteps e'
    , return (e,[])
    ]
    where
      pNumStep ex = do
        (_,b,math) <- choice'
          [ do
            meq <- skip
            (r :==: a) <- getEq meq
            meq2 <- skip
            (n :==: b) <- getEq meq2
            guard (isNat a && isNat b)

            choice'
              [ do
                guard ((n == Var "N" || n == Var "n") && (r == Var "R" || r == Var "r"))
                return (a,b,meq2)
              , do
                guard ((r == Var "N" || r == Var "n") && (n == Var "R" || n == Var "r"))
                return (b,a,meq)
              ]
          , do
            meq <- skip
            (n :==: b) <- getEq meq
            guard (n == Var "N" || n == Var "n")
            return (n,b,meq)
          ]
        (b',attr) <- isVal ex b
        return (b', Step (newId "") (math,attr) [])

isVal :: Expr -> Expr -> SEParser (Expr, [Attribute])
isVal e1 e2 =
  maybeToParse $ msum
    [ do
      guard $ isNat $ nf $ (e2-e1)/2
      return (e2,[])
    , do
      guard $ isNat $ nf $ (e2-e1)/3
      return (e2,[CommonMistake])
    , do
      guard $ isNat $ nf $ (e2-e1)/1
      return (e2,[CommonMistake])
    ]