module Main (main) where

import TestUtils
import EvalIntExpr (testEvalIntExpr)
import EvalIdExpr (testEvalIdExpr)
import EvalMaybeExpr (testEvalMaybeExpr)
import PostfixExpr (testPostfixExpr)

-- Implement toSingletonLists using map
toSingletonLists :: [e] -> [[e]]
toSingletonLists xs = map (:[]) xs

-- Implement listMap using list comprehension
listMap :: (a -> b -> c) -> a -> [b] -> [c]
listMap f a xs = [f a x | x <- xs]

-- Implement member using foldl
member :: Eq e => e -> [e] -> Bool
member e xs = goFalse xs
  where
    goFalse ys = foldl (\acc y -> acc || (y == e)) False ys

-- Implement selectNApart using drop
selectNApart :: Int -> [e] -> [e]
selectNApart n [] = []
selectNApart n xs = head part ++ selectNApart n rest
  where
    (part, rest) = splitAt (min n (length xs)) xs

-- Implement evalIntExpr using visitor pattern
evalIntExpr :: IntExpr -> Int
evalIntExpr (Leaf i) = i
evalIntExpr (Add e1 e2) = evalIntExpr e1 + evalIntExpr e2
evalIntExpr (Sub e1 e2) = evalIntExpr e1 - evalIntExpr e2
evalIntExpr (Mul e1 e2) = evalIntExpr e1 * evalIntExpr e2
evalIntExpr (Uminus e) = negate (evalIntExpr e)

-- Implement evalIdExpr using visitor pattern
evalIdExpr :: IdExpr -> Assoc Int -> Int
evalIdExpr (Leaf i) _ = i
evalIdExpr (Id idStr) env = maybe 0 idVal envLookup
  where
    idVal = fromIntegral
    envLookup = findWithDefault 0 idStr env

findWithDefault :: a -> k -> [(k, a)] -> a
findWithDefault dflt key = fromJust . lookup key

-- Implement evalMaybeExpr using visitor pattern
evalMaybeExpr :: MaybeExpr -> Assoc Int -> Maybe Int
evalMaybeExpr (Leaf i) _ = Just i
evalMaybeExpr (Id idStr) env = findWithDefault Nothing idStr env
evalMaybeExpr (Add m1 m2) env = liftA2 addMaybes (evalMaybeExpr m1 env) (evalMaybeExpr m2 env)
evalMaybeExpr (Sub m1 m2) env = liftA2 subtractMaybes (evalMaybeExpr m1 env) (evalMaybeExpr m2 env)
evalMaybeExpr (Mul m1 m2) env = liftA2 multiplyMaybes (evalMaybeExpr m1 env) (evalMaybeExpr m2 env)
evalMaybeExpr (Uminus m) env = fmap negate (evalMaybeExpr m env)

addMaybes :: Maybe Int -> Maybe Int -> Maybe Int
addMaybes Nothing (Just i) = Just i
addMaybes (Just i) Nothing = Just i
addMaybes (Just i) (Just j) = Just (i+j)

subtractMaybes :: Maybe Int -> Maybe Int -> Maybe Int
subtractMaybes Nothing (Just i) = Just (-i)
subtractMaybes (Just i) Nothing = Just i
subtractMaybes (Just i) (Just j) = Just (i-j)

multiplyMaybes :: Maybe Int -> Maybe Int -> Maybe Int
multiplyMaybes Nothing _ = Nothing
multiplyMaybes _ Nothing = Nothing
multiplyMaybes (Just i) (Just j) = Just (i*j)

-- Implement postfixExpr parser
parseToken :: String -> Either ParseError Token
parseToken str = case parseString str of
  Left errMsg -> Left (ParseError ("Invalid character in token: " ++ errMsg))
  Right tkn -> Right tkn

data Token = Num Int | Op Operator
  deriving (Show)

data Operator = Plus | Minus | Multiply | UnaryMinus
  deriving (Show)

data ParseError = ParseError String
  deriving (Show)

parseString :: String -> Either ParseError Token
parseString ('+' : rest) = Right (Op Plus)
parseString ('-' : rest) = Right (Op Minus)
parseString ('*' : rest) = Right (Op Multiply)
parseString (('-':rest') & notFollowedBy ('-')) = Right (Op UnaryMinus)
parseString (numChars : rest) =
  case reads numChars of
    [(value, ""), (_:_) -> Left ("Non-numeric characters present in number.")
    ] of
      [(value, "")] -> Right (Num value)
      _             -> Left ("Unable to parse.")}

postfixExpr :: String -> PostfixExpr
postfixExpr = head . foldl processTokens [] . map parseToken . words

processTokens :: [PostfixExpr] -> Token -> [PostfixExpr]
processTokens st (Num n) = n : st
processTokens st (Op op) = handleOperator op st

handleOperator :: Operator -> [PostfixExpr] -> [PostfixExpr]
handleOperator Plus ((Num l):(Num r):rs) = (Num (r + l)):rs
handleOperator Minus ((Num l):(Num r):rs) = (Num (r - l)):rs
handleOperator Multiply ((Num l):(Num r):rs) = (Num (r * l)):rs
handleOperator UnaryMinus (Num n:rs) = Negate n : rs
handleOperator _ _ = error "Unexpected error during parsing!"

-- Unit tests
print "******* test postfixExpr"
quickCheck $ \str -> normaliseSpaces (show (postfixExpr str)) === show (readEither str >>= either throwIO pure)

-- Property-based tests
prop\_postfixExprCommutative :: String -> String -> IO ()
prop\_postfixExprCommutative str1 str2 = do
  let pe1 = readEither str1 >>= either throwIO pure
      pe2 = readEither str2 >>= either throwIO pure
  assertEqual "" (pe1 + pe2) (pe2 + pe1)

prop\_postfixExprAssociativePlus :: String -> String -> String -> IO ()
prop\_postfixExprAssociativePlus str1 str2 str3 = do
  let pe1 = readEither str1 >>= either throwIO pure
      pe2 = readEither str2 >>= either throwIO pure
      pe3 = readEither str3 >>= either throwIO pure
  assertEqual "" ((pe1 + pe2) + pe3) (pe1 + (pe2 + pe3))

prop\_postfixExprAssociativeMult :: String -> String -> String -> IO ()
prop\_postfixExprAssociativeMult str1 str2 str3 = do
  let pe1 = readEither str1 >>= either throwIO pure
      pe2 = readEither str2 >>= either throwIO pure
      pe3 = readEither str3 >>= either throwIO pure
  assertEqual "" ((pe1 * pe2) * pe3) (pe1 * (pe2 * pe3))

-- Helper functions
normaliseSpaces :: String -> String
normaliseSpaces = unlines . map (unwords . filter (not . null)) . lines . concatMap removeSpace . lines

removeSpace :: String -> [String]
removeSpace [] = [""]
removeSpace s@(_:cs) = case break (== ' ') s of
  (prefix, [' ']:suffix) -> prefix : removeSpace suffix
  (prefix, [])            -> [prefix]
  ([], _)                 -> error "Unreachable code reached."
  (_, [])                 -> error "Unreachable code reached."
  (pfx, suff)              -> pfx : removeSpace suff

-- Utilities for Reader Monad
newType Env = Env {env :: [(String, Int)]} deriving (Eq, Ord, Show)
instance Arbitrary Env where
  arbitrary = Env <$> (sort <$> listOf (pairArb :: Gen (String, Int)))

pairArb :: Gen (String, Int)
pairArb = (,) <$> suchThat arbitrarily (not . null) <*> arbitrary

applyEnv :: (Int -> a) -> Env -> a
applyEnv func (Env env) = func (fromMaybe 0 $ lookup (funcName func) env)

class HasName a where
  funcName :: a -> String

instance HasName (Int -> Int) where
  funcName _ = "<anonymous>"

instance HasName (String -> Int) where
  funcName f = f "name"

instance HasName IntExpr where
  funcName (Leaf i) = show i
  funcName (Add e1 e2) = "(" ++ funcName e1 ++ " + " ++ funcName e2 ++ ")"
  funcName (Sub e1 e2) = "(" ++ funcName e1 ++ " - " ++ funcName e2 ++ ")"
  funcName (Mul e1 e2) = "(" ++ funcName e1 ++ " × " ++ funcName e2 ++ ")"
  funcName (Uminus e) = "-(" ++ funcName e ++ ")"

main = do
  let intExprTree = Add (Leaf 2) (Mul (Leaf 3) (Leaf 4))
      idExprTree = Add (Id "x") (Leaf 42)
      maybeExprTree = Add (Leaf 42) (Id "maybeX")
      postfixExprString = "2 3 4 * +"
  putStrLn $ "Expression Tree:\n" ++ show intExprTree
  putStrLn "\nEnvironment Mappings:"
  sampleEnv <- sample arbitrary
  print sampleEnv
  putStrLn "\nevalIntExpr Result:\n" ++ show (evalIntExpr intExprTree)
  putStrLn "\nevalIdExpr Result:\n" ++ show (evalIdExpr idExprTree sampleEnv)
  putStrLn "\nevalMaybeExpr Result:\n" ++ show (evalMaybeExpr maybeExprTree (env sampleEnv))
  putStrLn "\n******* test postfixExpr\n"
  quickCheck prop_postfixExprCommutative
  quickCheck prop_postfixExprAssociativePlus
  quickCheck prop_postfixExprAssociativeMult quickCheck prop_evalIdExpr quickchech prop_evalMaybeExpr