-----------------------------------------------------------------------------
-- 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.Exercises where

import Domain.Math.Approximation
import Common.Context
import Common.Exercise
import Common.Rewriting
import Common.Strategy
import Common.Traversable
import Common.Transformation
import Common.View
import Data.Maybe
import Domain.Math.Data.OrList
import Domain.Math.Data.Relation
import Domain.Math.Equation.Views
import Domain.Math.Examples.DWO1
import Domain.Math.Examples.DWO2
import Domain.Math.Expr
import Domain.Math.Polynomial.BuggyRules
import Domain.Math.Polynomial.CleanUp
import Domain.Math.Polynomial.Rules
import Domain.Math.Polynomial.Strategies
import Domain.Math.Polynomial.Views
import Domain.Math.Polynomial.Equivalence
import Domain.Math.Numeric.Views
import Control.Monad

------------------------------------------------------------
-- Exercises

linearExercise :: Exercise (Equation Expr)
linearExercise = makeExercise 
   { description  = "solve a linear equation"
   , exerciseCode = makeCode "math" "lineq"
   , status       = Provisional
   , parser       = parseExprWith (pEquation pExpr)
   , similarity   = eqRelation cleanUpSimple
   , equivalence  = viewEquivalent linearEquationView
   , isSuitable   = (`belongsTo` linearEquationView)
   , isReady      = solvedRelationWith $ \a -> 
                       a `belongsTo` mixedFractionNormalForm || 
                       a `belongsTo` rationalNormalForm
   , extraRules   = liftToContext buggyPlus : linearRules
   , strategy     = mapRules liftToContext linearStrategy
   , examples     = concat (linearEquations ++ [specialCases])
   }
 where
   specialCases = 
      let x = Var "x" 
      in [5 :==: x, 5 :==: x + 1, x - 1/5 :==: 2]
      
linearMixedExercise :: Exercise (Equation Expr)
linearMixedExercise = linearExercise 
   { description  = "solve a linear equation with mixed fractions"
   , exerciseCode = makeCode "math" "lineq-mixed"
   , isReady      = solvedRelationWith (`belongsTo` mixedFractionNormalForm)
   , strategy     = mapRules liftToContext linearMixedStrategy
   } 

quadraticExercise :: Exercise (OrList (Relation Expr))
quadraticExercise = makeExercise 
   { description  = "solve a quadratic equation"
   , exerciseCode = makeCode "math" "quadreq"
   , status       = Provisional
   , parser       = \input -> case parseExprWith (pOrList (pEquation pExpr)) input of
                                 Left err -> Left err
                                 Right xs -> Right (build (switchView equationView) xs)
   , similarity   = eqOrList cleanUpExpr2
   , equivalence  = equivalentRelation (viewEquivalent quadraticEquationsView)
   , isSuitable   = (`belongsTo` (switchView equationView >>> quadraticEquationsView))
   , isReady      = solvedRelations
   , extraRules   = map (liftToContext . liftRule (switchView equationView)) $ 
                       quadraticRules ++ abcBuggyRules
   , strategy     = quadraticStrategy
   , examples     = map (orList . return . build equationView) (concat quadraticEquations)
   }
   
higherDegreeExercise :: Exercise (OrList (Relation Expr))
higherDegreeExercise = makeExercise 
   { description   = "solve an equation (higher degree)"
   , exerciseCode  = makeCode "math" "higherdegree"
   , status        = Provisional
   , parser        = parser quadraticExercise
   , similarity    = eqOrList cleanUpExpr2
   , eqWithContext = Just $ eqAfterSubstitution $ 
                        equivalentRelation (viewEquivalent higherDegreeEquationsView)
   , isSuitable    = (`belongsTo` (switchView equationView >>> higherDegreeEquationsView))
   , isReady       = solvedRelations
   , extraRules    = map (liftToContext . liftRule (switchView equationView)) higherDegreeRules
   , strategy      = higherDegreeStrategy
   , examples      = map (orList . return . build equationView) 
                        (concat $ higherEq1 ++ higherEq2 ++ [higherDegreeEquations])
   }
   
quadraticNoABCExercise :: Exercise (OrList (Relation Expr))
quadraticNoABCExercise = quadraticExercise
   { description  = "solve a quadratic equation without abc-formula"
   , exerciseCode = makeCode "math" "quadreq-no-abc"
   , status       = Alpha
   , strategy     = configure cfg quadraticStrategy
   }
 where
   cfg = [ (ByName (name prepareSplitSquare), Reinsert)
         , (ByName (name bringAToOne), Reinsert)
         , (ByName "abc form", Remove)
         , (ByName (name simplerPoly), Remove)
         ]
         
quadraticWithApproximation :: Exercise (OrList (Relation Expr))
quadraticWithApproximation = quadraticExercise
   { description  = "solve a quadratic equation with approximation"
   , exerciseCode = makeCode "math" "quadreq-with-approx"
   , status       = Alpha
   , parser       = parseExprWith (pOrList (pRelation pExpr))
   , strategy     = configure cfg quadraticStrategy
   , equivalence  = equivalentApprox
   }
 where
   cfg = [ (ByName "approximate result", Reinsert)
         , (ByName "square root simplification", Remove)
         ]

-- fixMe = checksForList quadraticWithApproximation

findFactorsExercise :: Exercise Expr
findFactorsExercise = makeExercise
   { description  = "factorize the expression"
   , exerciseCode = makeCode "math" "factor"
   , status       = Provisional
   , parser       = parseExprWith pExpr
   , similarity   = \a b -> cleanUpExpr a == cleanUpExpr b
   , equivalence  = viewEquivalent (polyViewWith rationalView)
   , isReady      = (`belongsTo` linearFactorsView)
   , strategy     = mapRules liftToContext findFactorsStrategy
   , examples     = concat findFactors
   }

linearFactorsView :: View Expr (Bool, [(String, Expr, Expr)])
linearFactorsView = productView >>> second (listView myLinearView)
 where
   myLinearView :: View Expr (String, Expr, Expr)
   myLinearView = makeView f (build linearView)
   
   f expr = do 
      triple@(_, e1, e2) <- match linearView expr 
      a <- match integerView e1
      b <- match integerView e2
      guard (a > 0 && gcd a b == 1) -- gcd 0 0 is undefined
      return triple
    `mplus` do
      guard (expr `belongsTo` rationalView)
      return ("x", 0, expr)

--------------------------------------------
-- Equality

equivalentApprox :: OrList (Relation Expr) -> OrList (Relation Expr) -> Bool
equivalentApprox a b
   | hasApprox a || hasApprox b = 
        let norm = liftM ( normOrList cleanUpExpr 
                         . fmap toApprox 
                         . simplify quadraticEquationsView
                         ) . switch . fmap toEq
        in fromMaybe False $ liftM2 (==) (norm a) (norm b)
   | otherwise =
        equivalentRelation (viewEquivalent quadraticEquationsView) a b 
 where
   hasApprox = maybe False (any isApproximately) . disjunctions
   isApproximately = (==Approximately) . relationType
   toEq rel | relationType rel `elem` [EqualTo, Approximately] = 
      Just (leftHandSide rel :==: rightHandSide rel)
            | otherwise = Nothing
   toApprox (a :==: b) =
      let f x = case match doubleView x of
                   Just d  -> Number (precision 4 d)
                   Nothing -> x
      in f a .~=. f b
      
equivalentRelation :: (OrList (Equation a) -> OrList (Equation a) -> Bool) -> OrList (Relation a) -> OrList (Relation a) -> Bool
equivalentRelation f ra rb = fromMaybe False $ do
   a <- switch (fmap (match equationView) ra)
   b <- switch (fmap (match equationView) rb)
   return (f a b)

eqOrList :: (Relational f, Ord (f Expr)) => 
               (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) -> Bool
eqOrList f x y = normOrList f x == normOrList f y

eqRelation :: (Relational f, Eq (f Expr)) => 
                 (Expr -> Expr) -> f Expr -> f Expr -> Bool
eqRelation f x y = normRelation f x == normRelation f y

normOrList :: (Relational f, Ord (f Expr)) => 
                 (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr)
normOrList f = normalize . fmap (normRelation f)

normRelation :: Relational f => (Expr -> Expr) -> f Expr -> f Expr
normRelation f rel
   | leftHandSide new > rightHandSide new && isSymmetric new = flipSides new
   | otherwise = new
 where
   new = fmap (normExpr f) rel

normExpr :: (Expr -> Expr) -> Expr -> Expr
normExpr f = normalizeWith [plusOperator, timesOperator] . f
 where
   plusOperator  = acOperator (+) isPlus
   timesOperator = acOperator (*) isTimes
   
-- TODO: move this definition
buggyPlus :: Rule (Equation Expr)
buggyPlus = buggyRule $ makeSimpleRuleList "buggy plus" $ \(lhs :==: rhs) -> do
   (a, b) <- matchM plusView lhs
   [ a :==: rhs + b, b :==: rhs + a ]
 `mplus` do
   (a, b) <- matchM plusView rhs
   [ lhs + a :==: b, lhs + b :==: a ]