(******************************************************************************
 * SNU 4190.310 Programming Languages (Fall 2006)
 *
 * HW 2: essay, K- interpreter
 ******************************************************************************)

(******************************************************************************
 * Exercise 1.
 * nML exercise I: eval
 ******************************************************************************)

type formula
  = TRUE
  | FALSE
  | NOT of formula
  | ANDALSO of formula * formula
  | ORELSE of formula * formula
  | IMPLY of formula * formula
  | LESS of expr * expr
and expr = NUM of int | PLUS of expr * expr | MINUS of expr * expr

fun eval TRUE = True
  | eval FALSE = False
  | eval (NOT f) = not (eval f)
  | eval (ANDALSO (f, f')) = (eval f) && (eval f')
  | eval (ORELSE (f, f')) = (eval f) || (eval f')
  | eval (IMPLY (f, f')) = (not (eval f)) || (eval f')
  | eval (LESS (e, e')) = (eval' e) < (eval' e')
and eval' (NUM n) = n
  | eval' (PLUS (e, e')) = (eval' e) + (eval' e')
  | eval' (MINUS (e, e')) = (eval' e) - (eval' e')


(******************************************************************************
 * Exercise 2.
 * K- Interpreter I
 ******************************************************************************)

(* Memory *)
signature MEM =
  sig
    (* The type of address *)
    type address

    (* The type of memory from type address to type 'a *)
    type 'a t

    exception Not_allocated
    exception Not_initialized

    (* The empty memory *)
    val empty : 'a t

    (*
     * allocate m returns an address to a fresh (uninitialized) buffer and a
     * memory containing the same bindings as m, plus a binding of the address
     * to the allocated buffer.
     *)
    val allocate : 'a t -> address * 'a t

    (*
     * store addr v m returns a memory containing the same bindings as m, with
     * addr bounded to v, or raises Not_allocated if m doesn't contain a 
     * binding for addr.
     *)
    val store : address -> 'a -> 'a t -> 'a t

    (*
     * fetch addr m returns the current binding of addr in m, raises
     * Not_initialized if the binding is not initialized yet or raises
     * Not_found if no such binding exists.
     *)
    val fetch : address -> 'a t -> 'a

    (*
     * is_allocated addr m returns true if m contains a binding for addr, and
     * false otherwise.
     *)
    val is_allocated : address -> 'a t -> bool
  end

structure Mem : MEM =
  struct
    type address = int
    type 'a t = address * ((address, 'a option) Map.t)

    exception Not_allocated
    exception Not_initialized

    val empty = (0, Map.empty)
    fun allocate (n, m) = (n, (n + 1, Map.add n None m))
    fun store a v (n, m)  =
        if Map.mem a m then (n, Map.add a (Some v) m) else raise Not_allocated
    fun fetch a (_, m) = (
          case (Map.find a m) of Some v => v | None => raise Not_initialized
        ) handle Not_found => raise Not_allocated
    fun is_allocated a (_, m) = Map.mem a m
  end

(* Environment *)
signature ENV =
  sig
    (* The type of environment from 'a to 'b *)
    type ('a, 'b) t

    exception Not_bound

    (* The empty environment *)
    val empty : ('a, 'b) t

    (*
     * bind x addr e returns an environment containing the same bindings as
     * e, plus a binding of x to addr. If x was already bound in e, its
     * previous binding disappears.
     *)
    val bind : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t

    (*
     * lookup x e returns the current binding of x in e, or raises Not_bound if
     * no such binding exists.
     *)
    val lookup : 'a -> ('a, 'b) t -> 'b

    (*
     * is_bound x e returns true if e contains a binding for x, and false
     * otherwise.
     *)
    val is_bound : 'a -> ('a, 'b) t -> bool
  end

structure Env : ENV =
  struct
    type ('a, 'b) t = ('a, 'b) Map.t

    exception Not_bound

    val empty = Map.empty
    fun bind x a e = Map.add x a e
    fun lookup x e = (Map.find x e) handle Not_found => raise Not_bound
    fun is_bound x e = Map.mem x e
  end

(* K- Interpreter *)
signature KEVAL =
  sig
    exception Error of string
    type id = string
    type exp =
        NUM of int
      | TRUE
      | FALSE
      | UNIT
      | VAR of id
      | ADD of exp * exp
      | SUB of exp * exp
      | MUL of exp * exp
      | DIV of exp * exp
      | EQUAL of exp * exp
      | LESS of exp * exp
      | NOT of exp
      | ASSIGN of id * exp
      | SEQ of exp * exp
      | IF2 of exp * exp * exp
      | IF1 of exp * exp
      | WHILE of exp * exp
      | FOR of id * exp * exp * exp
      | LET of id * exp * exp
      | READ of id
      | WRITE of exp
    type program = exp
    type memory
    type env
    type value
    val emptyMem : memory
    val emptyEnv : env
    val run : memory * env * program -> value
  end

structure Keval : KEVAL =
  struct
    exception Error of string
    type id = string
    type exp =
        NUM of int
      | TRUE
      | FALSE
      | UNIT
      | VAR of id
      | ADD of exp * exp
      | SUB of exp * exp
      | MUL of exp * exp
      | DIV of exp * exp
      | EQUAL of exp * exp
      | LESS of exp * exp
      | NOT of exp
      | ASSIGN of id * exp
      | SEQ of exp * exp
      | IF2 of exp * exp * exp
      | IF1 of exp * exp
      | WHILE of exp * exp
      | FOR of id * exp * exp * exp
      | LET of id * exp * exp
      | READ of id
      | WRITE of exp
    type program = exp

    type value = Num of int | Bool of bool | Unit
    fun valueof (Num n) = Obj.magic n
      | valueof (Bool b) = Obj.magic b
      | valueof Unit = Obj.magic ()

    type memory = value Mem.t
    val emptyMem = Mem.empty

    type env = (id, Mem.address) Env.t
    val emptyEnv = Env.empty

    fun assert_type_equal (Num _) (Num _) = ()
      | assert_type_equal (Bool _) (Num _) = 
        raise (Error "Bool type is used as Num type")
      | assert_type_equal Unit (Num _) = 
        raise (Error "Unit type is used as Num type")
      | assert_type_equal (Num _) (Bool _) =
        raise (Error "Num type is used as Bool type")
      | assert_type_equal (Bool _) (Bool _) = ()
      | assert_type_equal Unit (Bool _) = 
        raise (Error "Unit type is used as Bool type")
      | assert_type_equal (Num _) Unit =
        raise (Error "Num type is used as Unit type")
      | assert_type_equal (Bool _) Unit =
        raise (Error "Bool type is used as Unit type")
      | assert_type_equal Unit Unit =  ()

    fun assert_bound x e =
        if Env.is_bound x e then () else raise (Error "not bound")

    fun run (memory, environment, program) = 
        let
          fun arithmetic env m op e1 e2 = 
              let
                val (n1, m1) = eval env m e1
                val () = assert_type_equal n1 (Num 0)
                val (n2, m2) = eval env m1 e2
                val () = assert_type_equal n2 (Num 0)
                val n = op (valueof n1) (valueof n2)
              in
                (Num n, m2)
              end
          and relational env m op e1 e2 =
              let
                val (v1, m1) = eval env m e1
                val (v2, m2) = eval env m1 e2
                val () = assert_type_equal v2 v1
              in
                (Bool (op (valueof v1) (valueof v2)), m2)
              end
          and eval env m (NUM n) = (Num n, m)
            | eval env m TRUE = (Bool True, m)
            | eval env m FALSE = (Bool False, m)
            | eval env m UNIT = (Unit, m)
            | eval env m (VAR x) =
              let
                val () = assert_bound x env
                val v = Mem.fetch (Env.lookup x env) m
              in
                (v, m)
              end
            | eval env m (ADD (e1, e2)) = arithmetic env m ( + ) e1 e2
            | eval env m (SUB (e1, e2)) = arithmetic env m ( - ) e1 e2
            | eval env m (MUL (e1, e2)) = arithmetic env m ( * ) e1 e2
            | eval env m (DIV (e1, e2)) = (
                (arithmetic env m ( / ) e1 e2) handle
                  Division_by_zero => raise (Error "Division_by_zero")
              )
            | eval env m (EQUAL (e1, e2)) = relational env m ( = ) e1 e2
            | eval env m (LESS (e1, e2)) = relational env m ( < ) e1 e2
            | eval env m (NOT e) =
              let
                val (b, m1) = eval env m e
                val () = assert_type_equal b (Bool False)
              in
                (Bool (not (valueof b)), m1)
              end
            | eval env m (ASSIGN (x, e)) =
              let
                val () = assert_bound x env
                val (v, m1) = eval env m e
              in
                (Unit, Mem.store (Env.lookup x env) v m1)
              end
            | eval env m (SEQ (e1, e2)) =
              let
                val (v1, m1) = eval env m e1
                val (v2, m2) = eval env m1 e2
              in
                (v2, m2)
              end
            | eval env m (IF2 (e1, e2, e3)) =
              let
                val (b, m1) = eval env m e1
                val () = assert_type_equal b (Bool False)
                val (v, m2) = (
                    case b of
                      Bool True => eval env m1 e2
                    | Bool False => eval env m1 e3
                    | _ => invalid_arg "eval"
                  )
              in
                (Unit, m2)
              end
            | eval env m (IF1 (e1, e2)) =
              let
                val (b, m1) = eval env m e1
                val () = assert_type_equal b (Bool False)
                val (v, m2) = (
                    case b of
                      Bool True => eval env m1 e2
                    | Bool False => (Unit, m1)
                    | _ => invalid_arg "eval"
                  )
              in
                (Unit, m2)
              end
            | eval env m (w as (WHILE (e1, e2))) =
              let
                val (b, m1) = eval env m e1
                val () = assert_type_equal b (Bool False)
                val (_, m2) = (
                    case b of
                      Bool True => eval env m1 (SEQ (e2, w))
                    | Bool False => (Unit, m1)
                    | _ => invalid_arg "eval"
                  )
              in
                (Unit, m2)
              end
            | eval env m (FOR (x, e1, e2, e3)) =
              let
                val (n1, m1) = eval env m e1
                val () = assert_type_equal n1 (Num 0)
                val (n2, m2) = eval env m1 e2
                val () = assert_type_equal n2 (Num 0)
              in
                if (valueof n1) <= (valueof n2) then
                  let
                    val (v, m3) =
                      eval env (Mem.store (Env.lookup x env) n1 m2) e3
                    val (u, m4) =
                      eval env m3 (FOR (x, NUM ((valueof n1) + 1), e2, e3))
                    val () = assert_type_equal u Unit
                  in
                    (Unit, m4)
                  end
                else (Unit, m2)
              end
            | eval env m (LET (x, e1, e2)) =
              let
                val (v1, m1) = eval env m e1
                val (v2, m2) =
                  let
                    val (l, m1') = Mem.allocate m1
                  in
                    eval (Env.bind x l env) (Mem.store l v1 m1') e2
                  end
              in
                (v2, m2)
              end
            | eval env m (READ x) =
              let
                val () = assert_bound x env
                val n =
                  (read_int ()) handle 
                    Failure "int_of_string" => raise (Error "int_of_string")
              in
                (Unit, Mem.store (Env.lookup x env) (Num n) m)
              end
            | eval env m (WRITE e) =
              let
                val (n, m1) = eval env m e
                val () = assert_type_equal n (Num 0)
                val () = print_int (valueof n) ; print_newline ()
              in
                (Unit, m1)
              end
        in
          fst (eval environment memory program)
        end
  end