Language5

module Main where

import System.Environment 
import System.IO 
import Data.Char

-- Parsing code: Parses into Nest data type
-- Our nesting in expressions is provided by square brackets.
import Text.ParserCombinators.Parsec

type Word = String
type Env = [(String, [Nest])]
type Stack = [Nest]

initlib = unlines[
  "[succ 1 +].",
  "[pred 1 -].",
  "[even? odd? not].",
  "[double dup +].",
  "[half dup odd? [succ 2 /] [2 /] if].",
  "[if* 2 nwrap [!] swap dip i if].",
  "[zero? 0 =?].", 
  "[factorial [zero?] [pop 1] [dup pred factorial *] if*]."
  ]

-- Read a line and Parse it, returing the Nest data structure.

readLine :: String -> Nest
readLine input = case parse parseExpr "nest" input of
    Left err -> error (show err)
    Right q -> q

eval :: String -> String
eval str = unwords $ map show $ bigStep [] e []
  where  Nested e = readLine (initlib ++ " " ++ str)

evalFile file = do
  str <- readFile file
  return $ eval str

main = do
  fn <- getArgs
  case fn of
      [] -> error "Need file.nst to evaluate."
      (x:xs) -> do res <- evalFile $ fn !! 0
                   putStrLn (show res)

-- Parse a number of words or nested structures.
parseExpr = do
  x <- many parseSingle
  return $ Nested x

-- Parse either a single word or a nested []
parseSingle :: Parser Nest
parseSingle = do
  spaces
  x <- (try parseFloat) <|>
       (try parseInt) <|>
       (try parseBool) <|>
       (try parseString) <|>
       (try parseWord) <|>
       (try parseNest)
  spaces
  return x

-- Parse a nested structure starting with [ and ending with ]
parseNest :: Parser Nest
parseNest = do
  char '['
  e <- parseExpr
  char ']'
  return e

parseFloat :: Parser Nest
parseFloat = do
  I i <- parseInt
  char '.'
  I j <- parseInt
  res <- return $ (show i) ++ ['.'] ++ (show j)
  return $ F (read res)

parseInt :: Parser Nest
parseInt = do
  i <- many1 digit
  return $ I (read i)

-- Parse a simple word without any spaces or nesting between them.
parseWord :: Parser Nest
parseWord = do
  w <- many1 (noneOf " nrt[]")
  return $ W w

parseBool :: Parser Nest
parseBool = do
  (x:xs) <- string "true" <|> string "false"
  return $ B (read (toUpper x : xs))

parseString :: Parser Nest
parseString = do
  char '''
  s <- many (noneOf "'")
  char '''
  return $ S s

-- bigStep semantics
bigStep :: Env -> [Nest] -> Stack -> Stack

-- Base case. Nothing on execution stack.
bigStep _ [] r = r

-- BigStep semantics for literals. i.e integers,
-- floats strings and nests evaluate to themselves.
bigStep env (Nested n: xs) ys = bigStep env xs (Nested n: ys)
bigStep env (I i: xs) ys = bigStep env xs (I i: ys)

-- implement the same for Float, Boolean, and String
bigStep env (F i: xs) ys = bigStep env xs (F i: ys)
bigStep env (B i: xs) ys = bigStep env xs (B i: ys)
bigStep env (S i: xs) ys = bigStep env xs (S i: ys)

-- BigStep Semantics for addition.
bigStep env (W "+": xs) (I i: I j: ys) = bigStep env xs (I (j+i): ys)
bigStep env (W "*": xs) (I i: I j: ys) = bigStep env xs (I (j*i): ys)
bigStep env (W "-": xs) (I i: I j: ys) = bigStep env xs (I (j-i): ys)
bigStep env (W "/": xs) (I i: I j: ys) = bigStep env xs (F ((fromIntegral j)/(fromIntegral i)): ys)
bigStep env (W ">": xs) (I i: I j: ys) = bigStep env xs (B (j > i): ys)
bigStep env (W "<": xs) (I i: I j: ys) = bigStep env xs (B (j < i): ys)

bigStep env (W "=?": xs) (I i: I j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (S i: S j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (B i: B j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (F i: F j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (Nested i: Nested j: ys) = bigStep env xs (B (j == i): ys)

bigStep env (W "odd?": xs) (I i: ys) = bigStep env xs (B (odd i): ys)

bigStep env (W "and": xs) (B a:B b:ys) = bigStep env xs (B (b && a):ys)
bigStep env (W "or": xs) (B a:B b:ys) = bigStep env xs (B (b || a):ys)
bigStep env (W "not": xs) (B a:ys) = bigStep env xs (B (not a):ys)

-- implement the same for - : if you have - a b , then the result
-- of (a - b) should be on the stack.
-- same for *. Can you implement it for division?
-- (hint, remember to use F Float for result)

-- implement the same for dup  : duplicate the topmost element.

bigStep env (W "dup": xs) (y:ys) = bigStep env xs (y:y:ys)

-- implement the same for swap : swap the two topmost elements.
bigStep env (W "swap": xs) (y:y':ys) = bigStep env xs (y':y:ys)

-- implement the same for pop : remove the topmost element.
bigStep env (W "pop": xs) (y:ys) = bigStep env xs ys

-- implement cons operator -- a:as in haskell
bigStep env (W "cons": xs) (Nested y':y:ys) = bigStep env xs (Nested (y:y'):ys)

-- implement concat operator -- ++ in haskell
bigStep env (W "concat": xs) (Nested y':Nested y:ys) = bigStep env xs (Nested (y ++ y'):ys)

-- implement empty? for a list.
bigStep env (W "empty?": xs) (Nested y:ys) = bigStep env xs (B (length y == 0):ys)

-- Another operator is nwrap that takes an integer and pulls out that many
-- elements in the stack into
-- a list.

bigStep env (W "nwrap": xs) (I i:ys) = bigStep env xs ((Nested lst) : rest)
  where lst = reverse $ take i ys
        rest = drop i ys

-- Remember the i combinator?  that is 
[1 2] i + == 3
[1 2 +] i == 3

-- implement the i. - pull out the topmost nesting out of the stack and push it into the execution queue

bigStep env (W "i":xs) (Nested v:ys) = bigStep env (v ++ xs) ys

-- implement ! it executes the statement on the stack non destructively.
-- 1 2 3 [+ +] ! == 1 2 3 6
-- 1 2 3 [+] ! == 1 2 3 5

bigStep env (W "!":xs) ys = bigStep env xs $ (head res):(tail ys)
  where res = bigStep env (W "i":xs) ys

-- We also need something called "dip" - an operator that pulls out the last
-- element from the stack, executes the current list on the remaining stack
-- elements and puts the pulled element back. This is useful to provide a
-- temporary place to store values. (see the example of if* to see how it is
-- used.)

bigStep env (W "dip":xs) (y:ys) = bigStep env xs $ y:lst
  where lst = bigStep env [W "i"] ys

-- if then else
bigStep env (W "if":xs) (Nested v2:Nested v1:B c:ys) = bigStep env (res ++ xs) ys
  where res = if c then v1 else v2

-- Implementing definitions.
bigStep env (W ".":xs) (Nested ((W w):as):ys) = bigStep ((w,as):env) xs ys

-- If not built in, look up in the environment.
bigStep env (W x :xs) ys = bigStep env (def ++ xs) ys
  where def = case lookup x env of
          Nothing -> error ("Definition not found or is not applicable for word  {" ++ x ++ "} with stack " ++ (show ys))  
          Just x -> x