--  hc - haskell command line calculator using rational numbers
--  Copyright (C) 2024 VegOwOtenks
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU Affero General Public License as published by
--  the Free Software Foundation, either version 3 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU Affero General Public License for more details.
--
--  You should have received a copy of the GNU Affero General Public License
--  along with this program.  If not, see <https://www.gnu.org/licenses/>.
--
--  contact me via vegowotenks at jossco dot de
module Lib
    ( exprparser, evaluate, replaceVars, Expr, extractVariableDefinitions, updateVariables, parseFullString
    ) where
import Control.Applicative((<*))

import Data.Ratio
import Data.Map (Map)
import qualified Data.Map as Map

import Text.Parsec
import Text.Parsec.Char
import Text.Parsec.String
import Text.Parsec.Expr
import Text.Parsec.Token
import Text.Parsec.Language

data Expr = Variable String | Constant Rational | Binary BinaryOperator Expr Expr | VariableDefinition String Expr
    deriving Show
data BinaryOperator = Plus | Minus | Multiply | Divide | Power
    deriving Show

naturalRatio a = a % 1

def = emptyDef{ commentStart = ""
              , commentEnd = ""
              , identStart = letter <|> char '_'
              , identLetter = alphaNum <|> char '_'
              , opStart = oneOf "+-/*^"
              , opLetter = oneOf "+-/*^"
              , reservedOpNames = ["+", "-", "/", "*", "^"]
              , reservedNames = []
              }

TokenParser{ parens = m_parens
           , identifier = m_identifier
           , reservedOp = m_reservedOp
           , reserved   = m_reserved
           , semiSep1   = m_semiSep1
           , natural    = m_natural
           , integer    = m_integer
           , whiteSpace = m_whiteSpace } = makeTokenParser def

parseFullString s = parse (m_whiteSpace *> exprparser <* eof) "<stdin>" s

exprparser :: Parser Expr
exprparser = buildExpressionParser table term <?> "expression"

table = [
            [
                Infix (m_reservedOp "^" >> return (Binary Power)) AssocLeft,
                Infix (m_reservedOp "^" >> return (Binary Power)) AssocLeft
            ],
            [
                Infix (m_reservedOp "*" >> return (Binary Multiply)) AssocLeft,
                Infix (m_reservedOp "/" >> return (Binary Divide)) AssocLeft
            ],
            [
                Infix (m_reservedOp "+" >> return (Binary Plus)) AssocLeft,
                Infix (m_reservedOp "-" >> return (Binary Minus)) AssocLeft
            ]
        ]

constantInteger :: Parser Rational
constantInteger = try (do
        _ <- m_whiteSpace
        n <- m_integer
        _ <- m_whiteSpace
        notFollowedBy . char $ '.'
        return (n % 1)
    )

constantRational :: Parser Rational
constantRational = do
    natural        <- m_natural
    _              <- char '.'
    _              <- m_whiteSpace
    decimal_digits <- many1 digit
    _              <- m_whiteSpace
    let decimal = read decimal_digits :: Integer
    let natural_length = length . show $ natural
    let decimal_length = length decimal_digits
    let numerator   = natural * (10 ^ decimal_length) + decimal
    let denominator = 10 ^ decimal_length
    return (numerator % denominator)

variableDefinition :: Parser Expr
variableDefinition = try (do
        name  <- m_identifier
        _     <- char '='
        value <- exprparser
        return (VariableDefinition name value)
    )

term = m_parens exprparser
       <|> variableDefinition
       <|> fmap Variable m_identifier
       <|> fmap Constant constantInteger
       <|> fmap Constant constantRational

extractVariableDefinitions :: Expr -> [(String,Expr)]
extractVariableDefinitions (VariableDefinition name value) = [(name, value)]
extractVariableDefinitions (Binary _ a b)                  = extractVariableDefinitions a  ++ extractVariableDefinitions b
extractVariableDefinitions (Constant _)                    = []
extractVariableDefinitions (Variable _)                    = []

updateVariables :: [(String, Expr)] -> Map String Rational -> Either String (Map String Rational)
updateVariables ds vs = foldl updateVariable (Right vs) ds

updateVariable :: Either String (Map String Rational) -> (String, Expr) -> Either String (Map String Rational)
updateVariable (Left  e)  _         = Left e
updateVariable (Right vs) (name, e) = case updateVariables nvs vs of
        Left e    -> Left $ "In definition of variable '" ++ name ++ "':\n" ++ e
        Right uvs -> case replaceVars e uvs of
            Left e    -> Left $ "In definition of variable '" ++ name ++ "':\n" ++ e
            Right exp -> Right $ Map.insert name (evaluate exp) uvs
    where
        nvs = extractVariableDefinitions e

replaceVars :: Expr -> Map.Map String Rational -> Either String Expr
replaceVars (Constant c)                  vs = Right $ Constant c
replaceVars (Variable name)               vs = maybe (Left ("Usage of unknown variable: '" ++ name ++ "'\nSuggestion: define the variable\n++  " ++ name ++ "=42")) (Right . Constant . id) $ Map.lookup name vs
replaceVars (VariableDefinition name _)   vs = replaceVars (Variable name) vs
replaceVars (Binary op l r)               vs = case leftBranch of
        Left  s -> Left  s
        Right a -> case rightBranch of
            Left s  -> Left s
            Right b -> Right $ Binary op a b
    where
        leftBranch  = replaceVars l vs
        rightBranch = replaceVars r vs

{-
 - a/b ^ c/d
 - (a ^ c/d) / b ^ (c/d)
 - root(a ^ c, d) / root(b ^ c, d)
 -}
rationalPower :: Rational -> Rational -> Rational
rationalPower a b = rationalPower' (numerator a, denominator a) (numerator b, denominator b)
    where
        rationalPower' (a, b) (c, 1) 
            | c >= 0    = a ^ c % b ^ c
            | otherwise = 1 / rationalPower (a % b) (-c % 1)
        rationalPower' _ _ = error "Powers with unnatural numbers are not supported yet"

evaluate :: Expr -> Rational
evaluate (Constant c) = c
evaluate (Binary Plus     a b)    = evaluate a + evaluate b
evaluate (Binary Minus    a b)    = evaluate a - evaluate b
evaluate (Binary Divide   a b)    = evaluate a / evaluate b
evaluate (Binary Multiply a b)    = evaluate a * evaluate b
evaluate (Binary Power    a b)    = rationalPower (evaluate a) (evaluate b)
evaluate (VariableDefinition _ _) = error "Unreachable Code"
evaluate (Variable _)             = error "Unreachable Code"