------------------------------------------------------------
-- Expression Calculator
------------------------------------------------------------
module Calc (
    Lexeme(..),
    spanLex,
    lexemes,
    evaluate
) where

import Data.List
import Data.Char

------------------------
-- Work with triples
------------------------
first :: (a, b, c)->a
first (x, _, _) = x

second :: (a, b, c)->b
second (_, y, _) = y

third :: (a, b, c)->c
third (_, _, z) = z

------------------------------------------------
-- Types of tokens
------------------------------------------------
data Lexeme = Number | LPar | RPar | 
              Plus | Minus | Mult | Div |
              Name | Empty | Illegal
              deriving (Eq, Show)

--------------------------------------------------------------------
-- Extract the first lexeme from the string
-- Return a pair:
-- ((lex. type, lex. value, lex. text), a rest of the string)
-- (the first component of pair is a triple that describes a lexeme)
--------------------------------------------------------------------
spanLex :: String->((Lexeme, Double, String), String)
spanLex str = spanLex' ("", Empty) str

spanLex' :: (String, Lexeme)->String->
            ((Lexeme, Double, String), String)
spanLex' (lexText, lex) []
    | lex == Number  = ((Number, read lexText::Double, lexText), [])
    | otherwise      = ((lex, 0.0, ""), [])
spanLex' (lexText, lex) str@(h:t)
    | lex == Empty =
      if isNumber h then spanLex' ([h], Number) t
      else if isAlpha h then spanLex' ([h], Name) t
      else if h == '(' then ((LPar, 0.0, [h]), t)
      else if h == ')' then ((RPar, 0.0, [h]), t)
      else if h == '+' then ((Plus, 0.0, [h]), t)
      else if h == '-' then ((Minus, 0.0, [h]), t)
      else if h == '*' then ((Mult, 0.0, [h]), t)
      else if h == '/' then ((Div, 0.0, [h]), t)
      else if isSpace h then spanLex' (lexText, lex) t    -- Ignore space
      else ((Illegal, 0.0, [h]), t)
    | lex == Number =
      let (digits, rest) = span (\ x -> isDigit x || x == '.') str
          txt = lexText ++ digits
          value = read (txt)::Double
      in ((Number, value, txt), rest)
    | lex == Name =
      let (letters, rest) = span isAlphaNum str
          txt = lexText ++ letters
      in ((Name, 0.0, txt), rest)
    | otherwise = error "spanLex error"

------------------------------------------------
-- Split a string into a list of lexemes
------------------------------------------------
lexemes :: String->[(Lexeme, Double, String)]
lexemes str = lexemes' [] str

lexemes' :: [(Lexeme, Double, String)]->String->
            [(Lexeme, Double, String)]
lexemes' acc [] = acc
lexemes' acc str =
    let (token, rest) = spanLex str
    in lexemes' (acc ++ [token]) rest

----------------------------------------
-- Context Free Grammar for Expressions
-- F -> T | F + T | F - T
-- T -> M | T * M | T / M
-- M -> n | ( F ) | -M | name ( F )
--
-- Transform in in left-recursive form
-- F -> T F'
-- F' -> eps | + T F' | - T F'
-- T -> M T'
-- T' -> eps | * M T' | / M T'
-- M -> n | ( F ) | -M  | name ( F )
----------------------------------------
evaluate :: String->Double
evaluate str =
    let 
        tokens = lexemes str
        (value, rest) = valueF tokens
        restNonempty = (length rest) >= 2 || 
                       (rest /= [] && first (head rest) /= Empty)
    in 
        if restNonempty then error "Syntax error: Incorrect end of formula"
        else value

valueF :: [(Lexeme, Double, String)]->
          (Double, [(Lexeme, Double, String)])
valueF tokens =
     let (t, rest) = valueT tokens
     in valueF' t rest

valueF' :: Double->[(Lexeme, Double, String)]->
           (Double, [(Lexeme, Double, String)])
valueF' acc ((Plus, _, _):tokens) =
     let (t, rest) = valueT tokens
     in valueF' (acc+t) rest
valueF' acc ((Minus, _, _):tokens) =
     let (t, rest) = valueT tokens
     in valueF' (acc-t) rest
valueF' acc tokens = (acc, tokens)

valueT :: [(Lexeme, Double, String)]->
          (Double, [(Lexeme, Double, String)])
valueT tokens =
     let (m, rest) = valueM tokens
     in valueT' m rest

valueT' :: Double->[(Lexeme, Double, String)]->
           (Double, [(Lexeme, Double, String)])
valueT' acc ((Mult, _, _):tokens) =
     let (m, rest) = valueM tokens
     in valueT' (acc*m) rest
valueT' acc ((Div, _, _):tokens) =
     let (m, rest) = valueM tokens
     in valueT' (acc/m) rest
valueT' acc tokens = (acc, tokens)

valueM :: [(Lexeme, Double, String)]->
          (Double, [(Lexeme, Double, String)])
valueM ((Number, value, _):rest) = (value, rest)
valueM ((LPar, _, _):tokens) =
    let 
        (f, rest) = valueF tokens
        errorSyntax = (rest == [] || first (head rest) /= RPar)
    in
        if errorSyntax then error "Syntax error: no )"
        else (f, tail rest)
valueM ((Minus, _, _):tokens) =
    let 
        (m, rest) = valueM tokens
    in
        (-m, rest)
valueM ((Name, _, txt):(LPar, _, _):tokens) =
    let 
        (f, rest) = valueF tokens
        errorSyntax = (rest == [] || first (head rest) /= RPar)
        m = if txt == "sin" then sin f
            else if txt == "cos" then cos f
            else if txt == "exp" then exp f
            else if txt == "log" then log f
            else if txt == "sqrt" then sqrt f
            else if txt == "atan" then atan f
            else error ("Error: Unknown function " ++ txt)
    in
        (m, tail rest)
valueM tokens = error "Syntax error"