(* Evaluator for GML *)

open Misc
open Format
open Gml
open Point
open Object

type value =
    B of bool
  | I of int
  | R of float
  | S of string
  | Arr of value array
  | Clos of environment * tok list
  | Point of Point.t
  | Obj of Object.t
  | Light of Light.t
  | Unknown

and environment = (string * value) list

exception Error of string

(* Environment management *)

let rec find x = function
    [] -> 
      raise (Error ("unbound identifier " ^ x))
  | (y, data) :: rem ->
      if x == y then data else find x rem

let rec replace x data = function
    [] -> raise Not_found
  | (y, _ as pair) :: rem ->
      if x == y then (x, data) :: rem else pair :: replace x data rem

let add x data env =
  try
    replace x data env
  with Not_found ->
    (x, data) :: env

(* Print a value (for debugging) *)

let rec print_val = function
    B b -> printf "%b" b
  | I i -> printf "%d" i
  | R r -> printf "%g" r
  | S s -> printf "\"%s\"" s
  | Arr a ->
      printf "@[<hov 2>[ ";
      for i = 0 to Array.length a - 1 do
        if i > 0 then printf "@ ";
        print_val a.(i)
      done;
      printf " ]@]"
  | Clos(env, tok) ->
      printf "<closure>"
  | Point p ->
      printf "<point %g %g %g>" p.x p.y p.z
  | Obj o ->
      printf "<object>"
  | Light l ->
      printf "<light>"
  | Unknown ->
      printf "<unknown>"

let print_value v = print_val v; printf "@."

let print_stack s =
  printf "@[<hov 2>( ";
  let first = ref true in
  List.iter
    (fun v ->
      if !first then first := false else printf "@ ";
      print_val v)
    (List.rev s);
  printf " )@]@."

(* Name of operators (for debugging) *)

let name_of_operator = function
    Op_acos -> "acos"
  | Op_addi -> "addi"
  | Op_addf -> "addf"
  | Op_apply -> "apply"
  | Op_asin -> "asin"
  | Op_clampf -> "clampf"
  | Op_cone -> "cone"
  | Op_cos -> "cos"
  | Op_cube -> "cube"
  | Op_cylinder -> "cylinder"
  | Op_difference -> "difference"
  | Op_divi -> "divi"
  | Op_divf -> "divf"
  | Op_eqi -> "eqi"
  | Op_eqf -> "eqf"
  | Op_floor -> "floor"
  | Op_frac -> "frac"
  | Op_get -> "get"
  | Op_getx -> "getx"
  | Op_gety -> "gety"
  | Op_getz -> "getz"
  | Op_if -> "if"
  | Op_intersect -> "intersect"
  | Op_length -> "length"
  | Op_lessi -> "lessi"
  | Op_lessf -> "lessf"
  | Op_light -> "light"
  | Op_modi -> "modi"
  | Op_muli -> "muli"
  | Op_mulf -> "mulf"
  | Op_negi -> "negi"
  | Op_negf -> "negf"
  | Op_plane -> "plane"
  | Op_point -> "point"
  | Op_pointlight -> "pointlight"
  | Op_real -> "real"
  | Op_render -> "render"
  | Op_rotatex -> "rotatex"
  | Op_rotatey -> "rotatey"
  | Op_rotatez -> "rotatez"
  | Op_scale -> "scale"
  | Op_sin -> "sin"
  | Op_sphere -> "sphere"
  | Op_spotlight -> "spotlight"
  | Op_sqrt -> "sqrt"
  | Op_subi -> "subi"
  | Op_subf -> "subf"
  | Op_translate -> "translate"
  | Op_union -> "union"
  | Op_uscale -> "uscale"
  | Op_print -> "print"
  | Op_printstack -> "printstack"

(* Evaluation function *)

let rec eval env stack code =
  match (code, stack) with
    ([], _) -> stack
  | (Identifier id :: rem, _) ->
      eval env (find id env :: stack) rem
  | (Binder id :: rem, v :: s) ->
      eval (add id v env) s rem
  | (Boolean b :: rem, _) ->
      eval env (B b :: stack) rem
  | (Integer i :: rem, _) ->
      eval env (I i :: stack) rem
  | (Real r :: rem, _) ->
      eval env (R r :: stack) rem
  | (String s :: rem, _) ->
      eval env (S s :: stack) rem
  | (Array toklist :: rem, _) ->
      let a = Array.of_list (List.rev (eval env [] toklist)) in
      eval env (Arr a :: stack) rem
  | (Function toklist :: rem, _) ->
      eval env (Clos(env, toklist) :: stack) rem
  | (Operator Op_apply :: rem, Clos(cenv, cbody) :: s) ->
      eval env (eval cenv s cbody) rem
  | (Operator Op_if :: rem,
      Clos(env2, body2) :: Clos(env1, body1) :: B b :: s) ->
      eval env (if b then eval env1 s body1 else eval env2 s body2) rem
  | (Operator op :: rem, s) ->
      eval env (evalop op s) rem
  | _ ->
      raise (Error "type error or stack underflow")

(* Evaluation of "primitive" operators (except if and apply).
   Note: I love pattern-matching! *)

and evalop op stack =
  match (op, stack) with
    (Op_acos, R r :: s) ->
      R(deg_acos r) :: s
  | (Op_addi, I i2 :: I i1 :: s) ->
      I(i1 + i2) :: s
  | (Op_addf, R r2 :: R r1 :: s) ->
      R(r1 +. r2) :: s
  | (Op_asin, R r :: s) ->
      R(deg_asin r) :: s
  | (Op_clampf, R r :: s) ->
      R(if r < 0.0 then 0.0 else if r > 1.0 then 1.0 else r) :: s
  | (Op_cone, Clos(env,body) :: s) ->
      Obj(Object.cone (surface_function 2 env body)) :: s
  | (Op_cos, R r :: s) ->
      R(deg_cos r) :: s
  | (Op_cube, Clos(env,body) :: s) ->
      Obj(Object.cube (surface_function 6 env body)) :: s
  | (Op_cylinder, Clos(env,body) :: s) ->
      Obj(Object.cylinder (surface_function 3 env body)) :: s
  | (Op_difference, Obj obj2 :: Obj obj1 :: s) ->
      Obj(Object.difference obj1 obj2) :: s
  | (Op_divi, I i2 :: I i1 :: s) ->
      (* On the x86, division is "impaire" and rounds towards zero, which is
         OK too *)
      if i2 = 0 then raise (Error "division by 0") else I(i1 / i2) :: s
  | (Op_divf, R r2 :: R r1 :: s) ->
      R(r1 /. r2) :: s
  | (Op_eqi, I i2 :: I i1 :: s) ->
      B(i1 = i2) :: s
  | (Op_eqf, R r2 :: R r1 :: s) ->
      B(r1 = r2) :: s
  | (Op_floor, R r :: s) ->
      I(truncate(floor r)) :: s
  | (Op_frac, R r :: s) ->
      let (frac, int) = modf r in R frac :: s
  | (Op_get, I i :: Arr a :: s) ->
      if i < 0 || i >= Array.length a
      then raise (Error "out-of-bound access in array")
      else Array.unsafe_get a i :: s
  | (Op_getx, Point p :: s) ->
      R p.x :: s
  | (Op_gety, Point p :: s) ->
      R p.y :: s
  | (Op_getz, Point p :: s) ->
      R p.z :: s
  | (Op_intersect, Obj obj2 :: Obj obj1 :: s) ->
      Obj(Object.intersect obj1 obj2) :: s
  | (Op_length, Arr a :: s) ->
      I(Array.length a) :: s
  | (Op_lessi, I i2 :: I i1 :: s) ->
      B(i1 < i2) :: s
  | (Op_lessf, R r2 :: R r1 :: s) ->
      B(r1 < r2) :: s
  | (Op_light, Point c :: Point dir :: s) ->
      Light(Light.directional dir c) :: s
  | (Op_modi, I i2 :: I i1 :: s) ->
      (* On the x86, (-a) mod b is -(a mod b) and a mod (-b) is a mod b,
         which is OK too *)
      if i2 = 0 then raise (Error "modulus by 0") else I(i1 mod i2) :: s
  | (Op_muli, I i2 :: I i1 :: s) ->
      I(i1 * i2) :: s
  | (Op_mulf, R r2 :: R r1 :: s) ->
      R(r1 *. r2) :: s
  | (Op_negi, I i :: s) ->
      I(- i) :: s
  | (Op_negf, R r :: s) ->
      R(-. r) :: s
  | (Op_plane, Clos(env,body) :: s) ->
      Obj(Object.plane (surface_function 1 env body)) :: s
  | (Op_point, R z :: R y :: R x :: s) ->
      Point {x = x; y = y; z = z} :: s
  | (Op_pointlight, Point c :: Point pos :: s) ->
      Light(Light.point pos c) :: s 
  | (Op_real, I i :: s) ->
      R(float i) :: s
  | (Op_render,
      S file :: I ht :: I wid :: R fov :: I depth :: Obj obj ::
      Arr vlights :: Point amb :: s) ->
      let lights =
        Array.map (function Light l -> l | _ -> raise (Error "light expected"))
        vlights in
      Render.render amb lights obj depth (fov *. degrees_to_radians)
      wid ht file;
      s
  | (Op_rotatex, R angle :: Obj obj :: s) ->
      Obj(Object.rotatex obj (angle *. degrees_to_radians)) :: s
  | (Op_rotatey, R angle :: Obj obj :: s) ->
      Obj(Object.rotatey obj (angle *. degrees_to_radians)) :: s
  | (Op_rotatez, R angle :: Obj obj :: s) ->
      Obj(Object.rotatez obj (angle *. degrees_to_radians)) :: s
  | (Op_scale, R sz :: R sy :: R sx :: Obj obj :: s) ->
      Obj(Object.scale obj sx sy sz) :: s
  | (Op_sin, R r :: s) ->
      R(deg_sin r) :: s
  | (Op_sphere, Clos(env,body) :: s) ->
      Obj(Object.sphere (surface_function 1 env body)) :: s
  | (Op_spotlight,
      R exp :: R cutoff :: Point c :: Point at :: Point pos :: s) ->
      Light(Light.spot pos at c (cutoff *. degrees_to_radians) exp) :: s
  | (Op_sqrt, R r :: s) ->
      if r >= 0.0 then R(sqrt r) :: s else raise(Error ("sqrt x, x < 0"))
  | (Op_subi, I i2 :: I i1 :: s) ->
      I(i1 - i2) :: s
  | (Op_subf, R r2 :: R r1 :: s) ->
      R(r1 -. r2) :: s
  | (Op_translate, R tz :: R ty :: R tx :: Obj obj :: s) ->
      Obj(Object.translate obj tx ty tz) :: s
  | (Op_union, Obj obj2 :: Obj obj1 :: s) ->
      Obj(Object.union obj1 obj2) :: s
  | (Op_uscale, R sc :: Obj obj :: s) ->
      Obj(Object.uscale obj sc) :: s
(* for testing *)
  | (Op_print, v :: s) ->
      print_value v; s
  | (Op_printstack, _) ->
      print_stack stack; stack
  | _ ->
      raise (Error ("type error or stack underflow in application of operator "
            ^ name_of_operator op))

(* Evaluate a surface function *)

and surface_function max_face env code =
(* Check for constant function.  A surface function is constant if
     it ignores its three parameters.  That is, when we feed it three
     "Unknown" parameters, it terminates without
     run-time type-error ("Unknown" doesn't belong to any type). *)
  try
    
    match eval env [Unknown; Unknown; Unknown] code with
      [R eta; R ks; R kd; Point p] ->
(* "Staticalize" the result *)
        let res = { color = p; kd = kd; ks = ks; phong = eta } in
        SurfConst res
    | _ ->
        raise (Error ("wrong result for constant surface function"))
  with Error _ ->
(* Non-constant function or type-incorrect function:
   see if it's constant for each face *)
      try
        let t = Array.init max_face
            (fun face ->
              match eval env [Unknown; Unknown; I face] code with
                [R eta; R ks; R kd; Point p] ->
(* "Staticalize" the result *)
                  { color = p; kd = kd; ks = ks; phong = eta }
                  | _ ->
                  raise (Error ("wrong result for constant surface function"))
          )
        in
        SurfArray t        
      with Error _ ->
(* Non-constant function or type-incorrect function: remain dynamic *)
          SurfFun (fun face u v ->
          match eval env [R v; R u; I face] code with
            [R eta; R ks; R kd; Point p] ->
              { color = p; kd = kd; ks = ks; phong = eta }
          | _ ->
              raise (Error ("wrong result for surface function")))

(* Evaluate the program *)

let eval_program p = ignore(eval [] [] p)