{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- 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)
--
-- Here we implemented the diagnosis for the magictrick exercise
--
-----------------------------------------------------------------------------

module Task.MagicTrick.Recognizer where

import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.List
import qualified Data.List.NonEmpty as N
import Data.Maybe
import Domain.Math.Data.Relation
import Domain.Math.Expr hiding (pExpr, fromDouble)
import Ideas.Common.Id
import Ideas.Utils.Uniplate
import Recognize.Data.Approach
import Recognize.Data.Attribute
import Recognize.Data.Math
import Recognize.Data.Op
import Recognize.Data.Diagnosis
import Recognize.Data.Step
import Recognize.Expr.Functions
import Recognize.Expr.Normalform
import Recognize.Parsing.Parse
import Recognize.Parsing.Derived
import Recognize.Parsing.MathParser      (parseMath)
import Recognize.Data.MathParserOptions
import Recognize.Strategy.Applications
import Recognize.SubExpr.SEParser
import Util.List
import Recognize.Data.MathStoryProblem
import Recognize.Data.MathParserOutput
import Recognize.Recognizer
import Task.MagicTrick.Assess
import Task.Network.MagicTrick
import Bayes.Probability ( fromDouble, Probability )
import Bayes.Network ( Node(..) )
import Bayes.Evidence ( Evidence, evidenceOfAbsence, nodeNotSet, nodeIsSet, nodeSetTo, (.=~) )

magicTrick :: MathStoryProblem
magicTrick = mathStoryProblem
   { problemId   = newId "magictrick"
   , analyzers   = [(newId "05", ana)]
   , inputFile   = Just "input/magictrick.csv"
   , networkFile = Just "networks/MagicTrick.xdsl"
   , singleNetwork = network
   }
 where
   ana = analyzer
      { recognizer = myrecognize
      , collector  = fillInMissedSteps . evidenceOfAbsence ans1 False . whereDidWeGoWrong . assess'
      }
   myrecognize po = seRecognizer pDiagnosis $ mathParserOutput po


{-
This module contains some postprocessing steps as a compromise to address a
number of issues we currently have:

1. There is an overwhelming bias toward positive rather than negative evidence.
2. There is not enough evidence in general, because the domain reasoner
allegedly produces evidence that is too shallow for the Bayesian networks to
work with. That is, it does not make "deep" judgments, like drawing conclusions
from steps that the student has skipped, or inferring that steps have been
taken from contextual clues.

Ideally, these problems would be solved by changing the way that the domain
reasoner works. However, that is infeasible in the current timeframe. Instead,
we will made judgment like these in a more ad-hoc manner: by transforming the
evidence, adding soft positive and negative evidence based on the hard, mostly
positive evidence found earlier.
-}

probHigh, probMediumLow, probLow :: [Probability]
probHigh = [fromDouble 0.8, fromDouble 0.2, fromDouble 0]
probMediumLow = [fromDouble 0.4, fromDouble 0.6, fromDouble 0]
probLow = [fromDouble 0.2, fromDouble 0.8, fromDouble 0]

-- | Postprocessing step on the found evidence: When there is no final answer,
-- but there are intermediate steps, we boldly assume that the step after the last
-- intermediate step was the culprit and we set its evidence to negative. If
-- there were no intermediate steps, we set the first step of each strategy to
-- negative.
whereDidWeGoWrong :: Evidence -> Evidence
whereDidWeGoWrong ev =
   if nodeIsSet ans1 ev
   then ev
   else mappend ev . additionalEvidence . flip map [strat1,strat2,strat3,strat4] $ \strat ->
      if studentTried strat ev
      then whereDidItGoWrong strat
      else Nothing

   where

   additionalEvidence nodes = mconcat $ case catMaybes nodes of
      [] -> map (.=~ probMediumLow) [ans1Strat1Step1, ans1Strat2Step1, ans1Strat3Step1, ans1Strat4Step1]
      other -> map (.=~ probLow) other

   studentTried :: [Node a] -> Evidence -> Bool
   studentTried strat ev' = any (flip nodeIsSet ev') strat 

   whereDidItGoWrong :: [Node a] -> Maybe (Node a)
   whereDidItGoWrong strat = listToMaybe . reverse . takeWhile (flip nodeNotSet ev) . reverse $ strat

   strat1 = [ans1Strat1Step1, ans1Strat1Step2, ans1Strat1Step3, ans1Strat1Step4, ans1Strat1Step5, ans1Strat1Step6]
   strat2 = [ans1Strat2Step1, ans1Strat2Step2, ans1Strat2Step3, ans1Strat2Step4, ans1Strat2Step5, ans1Strat2Step6, ans1Strat2Step7]
   strat3 = [ans1Strat3Step1, ans1Strat3Step2]
   strat4 = [ans1Strat4Step1, ans1Strat4Step2, ans1Strat4Step3, ans1Strat4Step4, ans1Strat4Step5, ans1Strat4Step6, ans1Strat4Step7]


-- | Postprocessing steps on the found evidence. 
-- When all the nodes on the LHS are present in the evidence but none on the
-- RHS are, we set evidence to the nodes on the RHS. Note that it is evaluated
-- left-to-right, so later steps should appear first. 
fillInMissedSteps :: Evidence -> Evidence
fillInMissedSteps = applyTransformations
   [
   -- Every next step implies the previous step
      ( nodeSetTo ans1Strat1Step6 (Just True)
      , ans1Strat1Step5 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat1Step5 (Just True)
      , ans1Strat1Step4 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat1Step4 (Just True)
      , ans1Strat1Step3 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat1Step3 (Just True)
      , ans1Strat1Step2 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat1Step2 (Just True)
      , ans1Strat1Step1 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step7 (Just True)
      , ans1Strat2Step6 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step6 (Just True)
      , ans1Strat2Step5 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step5 (Just True)
      , ans1Strat2Step4 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step4 (Just True)
      , ans1Strat2Step3 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step3 (Just True)
      , ans1Strat2Step2 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step2 (Just True)
      , ans1Strat2Step1 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat3Step2 (Just True)
      , ans1Strat3Step1 .=~ probHigh )

   -- Choose variable is implied by every later step
   ,  ( nodeSetTo ans1Strat1Step3 (Just True)
      , ans1Strat1Step1 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat1Step4 (Just True)
      , ans1Strat1Step1 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step3 (Just True)
      , ans1Strat2Step1 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step5 (Just True)
      , ans1Strat2Step1 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step6 (Just True)
      , ans1Strat2Step1 .=~ probHigh )
   ,  ( nodeSetTo ans1Strat2Step7 (Just True)
      , ans1Strat2Step1 .=~ probHigh )
   ]

   where
   applyTransformations :: [(Evidence -> Bool, Evidence)] -> Evidence -> Evidence
   applyTransformations = flip $ foldl (flip applyTransformation)

   applyTransformation :: (Evidence -> Bool, Evidence) -> Evidence -> Evidence
   applyTransformation (ante, post) ev = 
      case ante ev of
         True -> ev `mappend` post
         False -> ev



pDiagnosis :: SEParser Diagnosis
pDiagnosis = do
  sds <- pAttempts1
  -- TODO: Should perhaps also move the first algebraic attempt to the front
  return $ head sds

--Option that defines if we can take many buggy pars or only one
oTryManyBuggyPars :: Bool
oTryManyBuggyPars = True

--Option that defines if we can skip expressions
oSkipExpressions :: Bool
oSkipExpressions = True

-- wrapper around pAttempts; to only parse succesfull when at least one diagnosis has been matched.
pAttempts1 :: SEParser [Diagnosis]
pAttempts1 = do
  xs <- pAttempts
  when (null xs) empty
  return xs

-- | Tries to parse many attempts. If one fails then skip one input and try again until no input is left.
pAttempts :: SEParser [Diagnosis]                                 -- /--- a |> approach here, will cause Correct;garbage;garbage to process all possible fix first
pAttempts
  | oSkipExpressions = catMaybes <$> many (Just <$> pStdDiagnosis <|> Nothing <$ skip)
  | otherwise = many1 pStdDiagnosis

guessMagicExpr :: [Expr] -> [Expr]
guessMagicExpr [] = []
guessMagicExpr es@(e:_) = filter (matches es) z
   where
     z = nub $ [ x | Nat 8 :+: x <- universe e] -- niet efficient; maar willen prioriteit geven aan dit getal.
                              ++ [ x | x :+: Nat 8 <- universe e ] -- ,,
                              ++ concatMap f (universe e)
                              ++ [Nat 0]
     f v@(Nat _) = [v]
     f v@(Var _) = [v]
     f v@(Negate (Nat _)) = [v]
     f v@(Number _) = [v]
  -- function call
     f _ = []
     -- Tests whether the guessed magic expression is the actual magic expression
     -- we do this by looking for an expression of the form 8 + x or x + 8. The magic expression
     -- should then equal x. As a special case for x == 0, we also check for 8 * 3 and 3 * 8, in which
     -- case 0 is implicitly added to 8.
     -- Note that we only test against the first 3 following expressions. This is for 3 reasons:
     -- 1. Performance
     -- 2. Avoid overlapping with other attempts
     -- 3. Sometimes irrelevant expressions may be present
     matches es' m = all (all (\e' -> case e' of
       Nat 8 :+: x -> m == x
       x :+: Nat 8 -> m == x
       _ -> True) . universe) (take 3 es')

pMagicExpr :: SEParser Expr
pMagicExpr = withInputList (guessMagicExpr . mapMaybe getExpr)

pVars :: SEParser [String]
pVars = withInput (nub . concatMap vars . mapMaybe getExpr)

pAnnounce :: [String] -> Expr -> SEParser ()
pAnnounce vs x = () <$ many (() <$ pExpr x
                         <|> choice [ pEq $ Var v :==: x | v <-  vs ] )

pConclude :: [String] -> [Expr] -> Expr -> SEParser Expr
pConclude vs cs r =
    maybe r fst . uncons <$>
        many (choice ((7 <$ pExpr 7) : [ c <$ pEq (Var v :==: c) | v <- vs, c <- cs ]))

-- | Main diagnosis function.
--
-- First we guess some magic expression and then try to recognize the formula
pStdDiagnosis :: SEParser Diagnosis
pStdDiagnosis = do
  x <- pMagicExpr
  vs <- pVars
  -- pAnnounce vs x
  (a,st) <- pStepsFor x x (if x == 0 then taskIfZero else task x)

  res <- pConclude vs (nub [x,a]) a
  let attrs = map getAttributes st
  return Diagnosis
    { category = case x of { (Var _) -> Algebraic ; _ -> Numerical }
    , correctResult = res == 7 -- result is correct
    , resultIsSimplified = nf res == res -- nf result == result
    , parenthesisMismatch = any (elem NonMatchingParentheses) attrs
    , payload = Just x --The magic expression
    , steps = st
    , result = Just res
    }

task :: Expr -> [Op]
task me = [Add 8, Mul 3, Sub 4, Add me, Div 4, Add 2, Sub me]

taskIfZero :: [Op]
taskIfZero = [Add 8, Mul 3, Sub 4, Div 4, Add 2]

expandOps :: [Op] -> [Attribute]
expandOps = map Expand

taskExpand :: Expr -> [Attribute]
taskExpand = map Expand . task

taskForget :: Expr -> [Attribute]
taskForget = map Forget . task

-- | Pipeline for recognition
--
-- The pipeline consists of 4 phases:
--
-- * Parse correct steps
-- * Parse a simplification step
-- * Forget a step
-- * A mistake was made. Try fixing the step
--
-- These phases are passed through linearly, but a phase may go back to phase 1 before reaching the latter phases.
pStepsFor :: Expr -> -- magic expression
             Expr -> -- current expression
             [Op] -> -- remaining ops
             SEParser (Expr, [Step])
pStepsFor x a ops = do
  pLog $ "pStepsFor: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops
  option $ satisfyWith (getExpr >=> (\e -> guard (a == e)))
  -- Try to parse as many correct steps as possible
  eth <- pStepsPhase1 x a ops
  case eth of
    Left (e, st, ops') -> do
      pLog $ "Fail after phase1 " ++ show x ++ "  " ++ show st ++ "  " ++ show e ++ "  " ++ show ops'
      ms <- pStepsPhase2 x e
      case ms of
        Just (e', st') -> do
          pLog $ "success after phase2 " ++ show x ++ "  " ++ show st' ++ "  " ++ show e'
          second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' ops'

        Nothing -> do
          pLog "Fail after phase 2"
          -- Forget one step
          ma <- pStepsPhase3 x e ops'
          case ma of
            Just (e', st', ops'') -> do
              pLog $ "success after phase3 " ++ show x ++ "  " ++ show st' ++ "  " ++ show e' ++ "  " ++ show ops''
              -- After forgetting steps, we continue to try and parse correct steps
              second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' ops''

            Nothing -> do
              pLog $ "Failed phase3: " ++ show st ++ "  " ++ show e ++ "  " ++ show ops'
                -- If we could not continue by forgetting then we try fixing, if this also fails then the parsing fails
              (e', st', ops'') <- pStepsPhase4 x e ops' st
              pLog $ "success after phase4 " ++ show x ++ "  " ++ show st' ++ "  " ++ show e' ++ "  " ++ show ops'
              second (\st'' -> st' ++ st'') <$> pStepsFor x e' ops''
    Right (e, st, _) -> do
      pLog $ "Success after phase1: " ++ show st ++ " | " ++ show e
      ms <- pStepsPhase2 x e
      case ms of
        Just (e', st') -> do
          pLog $ "success after phase2 " ++ show x ++ "  " ++ show st' ++ "  " ++ show e'
          second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' []
        Nothing -> do
          pLog "done in StepsFor"
          return (e, st)

pStepsPhase1 :: Expr -> Expr -> [Op] -> SEParser (Either (Expr, [Step], [Op]) (Expr, [Step], [Op]))
pStepsPhase1 = pTask pStepOperators

pStepsPhase2 :: Expr -> Expr -> SEParser (Maybe (Expr, Step))
pStepsPhase2 = pTaskSimplify

pStepsPhase3 :: Expr -> Expr -> [Op] -> SEParser (Maybe (Expr, Step, [Op]))
pStepsPhase3 = pTaskErr

pStepsPhase4 :: Expr -> Expr -> [Op] -> [Step] -> SEParser (Expr, [Step], [Op])
pStepsPhase4 = pTaskForget

-- | Expands the current formula with a different number of operators.
--
-- Then attempts are made to recognize this formula.
pTask :: (Expr -> Expr -> [Op] -> SEParser (Expr, Step)) -- ^ to use recognition strategy
         -> Expr -- ^ magic expression
         -> Expr -- ^ current expression
         -> [Op] -- ^ remaining operators
         -> SEParser (Either (Expr, [Step], [Op]) (Expr, [Step], [Op]))
pTask _ _ a [] = return $ Right (a, [], [])
pTask strat x a xs = do
  pLog $ "pTask: " ++ show x ++ " | " ++ show a ++ " | " ++ show xs
  pTask'
  where
    pTask' =
      choice'
              [ do
                (b, as)  <- strat x a ops
                eth <- pTask strat x b ys
                case eth of
                  Left (c, cs, zs) -> return $ Left (c, as : cs, zs)
                  Right (c, cs, zs) -> return $ Right (c, as : cs, zs)
              | (ops, ys) <- splits xs, length ops > 0
              ]
      |> pIf (null xs)  (succeed $ Right (a, [], xs))
      |> succeed (Left (a, [], xs))

-- | tries to match the current formula to some simplified form of that formula
pTaskSimplify :: Expr -> Expr -> SEParser (Maybe (Expr, Step))
pTaskSimplify x a = do
  pLog $ "pTaskSimplify: " ++ show x ++ " | " ++ show a
  m <- withInput head
  if fst (simplify a) == a then return Nothing
   else do
    ma <- option $ pStepSimplify x a
    return $ ma >>= \(e, as) -> Just (e, smallStep (newId "simplify") (m,as))

-- | It's possible some operation was forgotten to be added
pTaskForget :: Expr -> Expr -> [Op] -> [Step] -> SEParser (Expr, [Step], [Op])
pTaskForget x a [Sub ope] stps -- special case necessary for if the last operator has been forgotten
  | x == ope || (isVar x && isVar ope) = return (a, modifyAt (length stps - 1) (addAttribute (Forget $ Sub x)) stps, [])
  | otherwise = empty
pTaskForget x a (op:op2:xs) stps = do
  (e,st) <- pStepForget x a op op2
  return (e, stps++[st], xs)
pTaskForget _ _ _ _ = empty

-- | See if an error was made given the next operation
pTaskErr :: Expr -> Expr -> [Op] -> SEParser (Maybe (Expr, Step, [Op]))
pTaskErr _ _ [] = empty
pTaskErr x a (op:xs) = option $ (\(e,st) -> (e,st,xs)) <$> pStepError x a [op]

pStepOperators :: Expr -- ^ magic expression
                -> Expr -- ^ the current expression
                -> [Op] -- ^ list of operators to be added
                -> SEParser (Expr, Step)
pStepOperators x a ops = do
  m <- withInput head
  (e,as) <- pStep x a ops
  let as' = map Expand ops ++ as
  return (e, smallStep (newId "") (m,as'))

pStepError :: Expr -- ^ magic expression
                -> Expr -- ^ the current expression
                -> [Op] -- ^ list of operators to be added
                -> SEParser (Expr, Step)
pStepError x a ops = do
  m <- withInput head
  (e,as) <- pStepErr x a ops
  return (e, smallStep (newId "") (m,as))

pStepForget :: Expr -- ^ magic expression
                -> Expr -- ^ the current expression
                -> Op -- ^ current step
                -> Op -- ^ next step
                -> SEParser (Expr, Step)
pStepForget x a op1 op2 = do
  m <- withInput head
  (e,as) <- pStep x a [op2]
  return (e, smallStep (newId "") (m,Forget op1 :as))

-- | Parse a step
--
-- Equation step, expression step or some erronuous step
pStep :: Expr -- ^ magic expression
      -> Expr -- ^ the current expression
      -> [Op] -- ^ list of operators to be added
      -> SEParser (Expr, [Attribute])
pStep x a ops =
  choice'
    [ do
      m <- peek
      guard $ isJust $ getEq m
      pStepEquation x a ops
    , do
      m <- peek
      guard $ isNothing $ getEq m
      pStepExpr x a ops
    , pBuggyStep x a ops
    ]

pStepErr :: Expr -> Expr -> [Op] -> SEParser (Expr, [Attribute])
pStepErr x a ops =
        -- pFixEqCom wil attempt to fix the equation to match the input
          pFixEqCom (b :==: b)
        |> choice [pFixEqCom (b :==: norm b) | norm <- [nfCom . nf]]
        |> pFixExprCom b
        |> choice [pFixExprCom (norm b) | norm <- [nfCom . nf]]
  where
    b = formExpr x a ops

pBuggyStep :: Expr -- ^ magic expression
           -> Expr -- ^ the current expression
           -> [Op] -- ^ list of operators to be added
           -> SEParser (Expr, [Attribute])
pBuggyStep x a ops =
  pIf (length ops >= 2) (
        ((,[IncorrectDistribution, Recovery])  . rightHandSide) <$> fst <$> pEqWith2 (\e -> (nfCom e,[])) (\e -> (nfCom $ nf e,[])) (b' :==: b)
     |> ((,[IncorrectDistribution] ) . rightHandSide) <$> fst <$> pEqWith2 (\e -> (nfCom e,[])) (\e -> (nfCom $ nf e,[])) (b' :==: b')
     |> (,[IncorrectDistribution]) <$> fst <$> pExprWith (\e -> (nfCom e,[])) b'
    )
  |> pIf (not $ null ops) (pNextStepBuggyPars a b)
 where
   b' = foldl (flip fromOp') a (map (substOp x) ops) -- b is a buggy parenthesis step
   b = formExpr x a ops

pStepSimplify :: Expr -- ^ magic expression
              -> Expr -- ^ the current expression
              -> SEParser (Expr, [Attribute])
pStepSimplify x a = do
  pLog $ "pStepSimplify: " ++ show x ++ " | " ++ show a
  choice'
    [ do
      m <- peek
      guard $ isJust $ getEq m
      (attr,e) <- pExplicitSimplifyEq x a
      return (attr,e)
    , do
      m <- peek
      guard $ isNothing $ getEq m
      (attr,e) <- pExplicitSimplifyExpr a
      return (attr,e)
    ]

pExplicitSimplifyEq :: Expr -- ^ magic expression
                    -> Expr -- ^ the current expression
                    -> SEParser (Expr, [Attribute])
pExplicitSimplifyEq x a = do
  pLog $ "pExplicitSimplifyEq: " ++ show x ++ " | " ++ show a
  choice
    [ first rightHandSide <$> pEqWith simplify (a :==: a)
    , pEqWithL simplify a
    ]

pExplicitSimplifyExpr :: Expr -- ^ the current expression
                      -> SEParser (Expr, [Attribute])
pExplicitSimplifyExpr = pExprWith simplify


{-
((x+8)*3-4+x)/4+2-x = 7
(3x +24 - 4 + x)/4+2-x = 7
-}

{-
((x+8)*3-4+x)/4+2-x = (3x +24 - 4 + x)/4+2-x
(3x + 24 - 4 + x)/4+2-x = (4x+20)/4+2-x
-}


pStepEquation :: Expr -- ^ magic expression
              -> Expr -- ^ the current expression
              -> [Op] -- ^ list of operators to be added
              -> SEParser (Expr, [Attribute])
pStepEquation x a ops = do
  pLog $ "pStepEquation: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops
  choice
    [ first rightHandSide <$> pEqWith simplify (b :==: b)
    , pEqWithL simplify b
    ]
  |> pIf (length ops <= 3)
        (pFixEqCom (b :==: nfCom (nf b)))
  where
    b = formExpr x a ops

-- | pStepExpr probeert een expressie te parsen
-- probeer eerst zonder normaliseren (maar modulo comm/assoc/distr)
-- probeer dan met normaliseren (dan telt de stap/berekening als impliciet)
-- probeer dan met fout correctie.
pStepExpr :: Expr -- ^ magic expression
          -> Expr -- ^ the current expression
          -> [Op] -- ^ list of operators to be added
          -> SEParser (Expr, [Attribute])
pStepExpr x a ops = do
  pLog $ "In pStepExpr: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops ++ " | " ++ show b
  pExprWith (\e -> (nfCom e, [])) b
  -- Be careful that you don't relax this condition too much. Otherwise any occurence of 7 can be seen as a fully expanded and simplified expression
  |> pIf (length ops < 4) (second (\attr -> (Implicit <$> ops)++attr) <$> pExprWith simplify b)
  where
    b = formExpr x a ops

pNextStepBuggyPars :: Expr -> Expr -> SEParser (Expr, [Attribute])
pNextStepBuggyPars _ b = let np = noPars b in choice'
   [ (lhs', [NonMatchingParentheses]) <$ pEqCom (lhs' :==: nf b)
     |> (lhs', [NonMatchingParentheses])  <$ pExprCom lhs'
     | lhs' <- np
   ]

splits :: [a] -> [([a], [a])]
splits xs = zip (inits xs) (tails xs)

pIf :: Alternative f => Bool -> f a -> f a
pIf b p = if b then p else empty

-- quick and dirty
noPars :: Expr -> [Expr]
noPars e = (if oTryManyBuggyPars then id else take 1) $ -- use take 1 to speed up the recognizer
            mapMaybe f (dropParensString (show e))
  where
    f s = case myparseExpr s of
      Just new | new /= e -> Just new
      _ -> Nothing

    myparseExpr s =
      case mapMaybe getExpr (snd $ parseMath mathParserOptions s) of
          [m] -> Just m
          _ -> Nothing


-- drop sets of corresponding parentheses
dropParensString :: String -> [String]
dropParensString = rec []
  where
    rec ps [] = [ "" | null ps ]
    rec ps (x:xs)
      | x == '('  = rec (False:ps) xs ++ map (x:) (rec (True:ps) xs)
      | x == ')'  = if null ps
                    then []
                    else if head ps
                          then map (x:) (rec (drop 1 ps) xs)
                          else rec (drop 1 ps) xs
      | otherwise = map (x:) (rec ps xs)

pFixEqCom :: Equation Expr -- ^ expected
          -> SEParser (Expr, [Attribute])
pFixEqCom e = peekEq >>= \eq -> pLog ("pFixEqCom: " ++ show e ++ " | " ++ show eq) >> pMatchEq e eq

pMatchEq :: Equation Expr -- ^ expected
         -> Equation Expr -- ^ provided
         -> SEParser (Expr, [Attribute])
pMatchEq (a :==: b) (x :==: y) =
      pIf (not (a === x) && any (=== x) (changeOp a) && y === x)
        (pRewrite (y, [OperatorMixedUp plusSymbol plusSymbol]))
  <|> pIf (a /= x) (pMatchExpr a x)
  <|> pIf (not (a === x) && b === y) (second (Recovery:) <$> pMatchExpr (nfCom a) (nfCom x))
  <|> pIf (not (a === x) && b == y) (pRewrite (y, [InvalidEquation x y, Recovery]))
  <|> pIf (a === x && (b /= y)) (pRewrite (y, [InvalidEquation x y]))

pFixExprCom :: Expr -> SEParser (Expr, [Attribute])
pFixExprCom e = peekExpr >>= pMatchExpr e

pMatchExpr :: Expr -- ^ expected
           -> Expr -- ^ provided
           -> SEParser (Expr, [Attribute])
pMatchExpr e p = choice
  [ do
    el <- maybeToParse $ getLeft e
    pl <- maybeToParse $ getLeft p
    let e' = replaceLeft pl e
    guard (e' == p)
    pRewrite (p, [AtomMixedUp pl el])
  , do
    er <- maybeToParse $ getRight e
    pr <- maybeToParse $ getRight p
    let e' = replaceRight pr e
    guard (e' == p)
    pRewrite (p, [AtomMixedUp pr er])
  , pIf (equivalentStructure e p
          && filter isAtom (universe e) == filter isAtom (universe p)
          && not (isAtom e)
         )
      (pRewrite (p, [OperatorMixedUp plusSymbol plusSymbol]))
  , pIf ((not.isAtom) e
          && equivalentStructure e p
          && length (changeSet e p) == 1
         )
      (pRewrite (p, [AtomMixedUp p e]))
  ]

pEqWith :: (Expr -> (Expr, [Attribute])) -> Equation Expr -> SEParser (Equation Expr, [Attribute])
pEqWith f x = do
  m <- satisfyWith Just
  pLog $ "pEqWith: " ++ show x ++ " | " ++ show m
  case getEq m of
    Just y -> do
      let xl = leftHandSide x
          yl = leftHandSide y
          (fxl,axl) = f xl
          (fxr,_)   = f (rightHandSide x)
          (fyl,ayl) = f yl
          (fyr,ayr) = f (rightHandSide y)
      guard (
        if xl == yl then fyl == fyr
                    else fxl == fyl && fyl == fyr && hasCommonality axl ayl && (hasCommonality ayl ayr || null ayr))
      pLog $ "pEqWith success: " ++ show fxl ++ "  " ++ show fxr ++ " | " ++ show fyl ++ " " ++ show fyr
      return (y, ayl \\ ayr)
    Nothing -> empty

pEqWith2 :: (Expr -> (Expr, [Attribute])) -> (Expr -> (Expr, [Attribute])) -> Equation Expr -> SEParser (Equation Expr, [Attribute])
pEqWith2 f g x = do
  m <- satisfyWith Just
  pLog $ "pEqWith2: " ++ show x ++ " | " ++ show m
  case getEq m of
    Just y -> do
      let (fx,_)   = f (leftHandSide x)
          (gx,_)   = g (rightHandSide x)
          (fy,aly) = f (leftHandSide y)
          (gy,ary) = g (rightHandSide y)
      guard (fx == fy && gx == gy)
      pLog $ "pEqWith2 success: " ++ show fx ++ " " ++ show fy ++ " | " ++ show gx ++ " " ++ show gy
      return (y, aly \\ ary)
    Nothing -> empty

{-|
Compares the left arguments of two subsequent equations

A = 7
B = 7
C = 7

In this case B should be a simplification of A and C a simplification of B.
-}
pEqWithL :: (Expr -> (Expr, [Attribute])) -> Expr -> SEParser (Expr, [Attribute])
pEqWithL f x = do
  m <- satisfyWith Just
  pLog $ "pEqWithL: " ++ show x ++ " | " ++ show m
  case getEq m of
    Just y -> do
      let (fx,ax)   = f x
          (fyl,ayl) = f (leftHandSide y)
          (fyr,_) = f (rightHandSide y)
      -- We require two things for x to match y.l:
      -- 1. The end result must be equal
      -- 2. There should be at least some common steps (ensures that two formulas don't match if they do not use the same magic variable)
      guard (fx == fyl && fyl == fyr && (hasCommonality ax ayl || null ayl)) -- ? ax ++
      pLog $ "pEqWith success: " ++ show fx ++ "  " ++ show fyl ++ " " ++ show fyr
      return (leftHandSide y, ax \\ ayl)
    Nothing -> empty

-- | Two expressions might simplify to the same expression, but their paths there are different.
--
-- This function will check that there was at least one common step in simplification.
hasCommonality :: [Attribute] -> [Attribute] -> Bool
hasCommonality xs ys =
  let xs' = map nfa xs
      ys' = map nfa ys
  in any (`elem` xs') ys'

  where
    nfa (ARule i a b) = ARule i (N.map nfComAssoc a) (nfComAssoc b)
    nfa r = r