open Syntax
open Value

(* 実際の計算をする関数 *)
(* Defunctionalized Interpreter : eval10 *)

(* cons : c -> s -> t -> t *)
let rec cons c s t = match t with
    TNil -> Trail (c, s)
  | Trail (c', s') -> Trail (CAppend (c, c'), SAppend (s, s'))

(* apnd : t -> t -> t *)
let apnd t0 t1 = match t0 with
    TNil -> t1
  | Trail (c, s) -> cons c s t1

(* run_c10 : c -> s -> t -> m -> v *)
let rec run_c10 c s t m = match c with
    CNil ->
    begin match s with
        SCons (v, SNil) ->
        begin match t with
            TNil ->
            begin match m with
                [] -> v
              | (c, s, t) :: m -> run_c10 c (SCons (v, s)) t m
            end
          | Trail (c, s) -> run_c10 c (SCons (v, s)) TNil m
        end
      | _ -> failwith "stack error"
    end
  | CCons (i, c) -> run_i10 i s c t m
  | CAppend (c, c') ->
    begin match s with
        SCons (v, SAppend (s, s')) -> run_c10 c (SCons (v, s)) (cons c' s' t) m
      | _ -> failwith "stack error"
    end

(* run_i10 : i -> s -> c -> t -> m -> v *)
and run_i10 i s c t m = match i with
    INum (v) ->
    begin match s with
        SCons (VEnv (vs), s) -> run_c10 c (SCons (v, s)) t m
      | _ -> failwith "stack error"
    end
  | IAccess (n) ->
    begin match s with
        SCons (VEnv (vs), s) -> run_c10 c (SCons (List.nth vs n, s)) t m
      | _ -> failwith "stack error"
    end
  | IPush_closure (i) ->
    begin match s with
        SCons (VEnv (vs), s) -> run_c10 c (SCons (VFun (i, vs), s)) t m
      | _ -> failwith "stack error"
    end
  | IReturn ->
    begin match s with
        SCons (v, SCons (VK (c), s)) -> run_c10 c (SCons (v, s)) t m
      | _ -> failwith "stack error"
    end
  | IPush_env ->
    begin match s with
        SCons (VEnv (vs), s) ->
        run_c10 c (SCons (VEnv (vs), SCons (VEnv (vs), s))) t m
      | _ -> failwith "stack error"
    end
  | IPop_env ->
    begin match s with
        SCons (v0, SCons (VEnv (vs), s)) ->
        run_c10 c (SCons (VEnv (vs), SCons (v0, s))) t m
      | _ -> failwith "stack error"
    end
  | IOperations (op) ->
    begin match s with
        SCons (v1, SCons (v0, s)) ->
        begin match (v0, v1) with
            (VNum (n0), VNum (n1)) ->
            begin match op with
                Plus -> run_c10 c (SCons (VNum (n0 + n1), s)) t m
              | Minus -> run_c10 c (SCons (VNum (n0 - n1), s)) t m
              | Times -> run_c10 c (SCons (VNum (n0 * n1), s)) t m
              | Divide ->
                if n1 = 0 then failwith "Division by zero"
                else run_c10 c (SCons (VNum (n0 / n1), s)) t m
            end
          | _ -> failwith "op is number only"
        end
      | _ -> failwith "stack error"
    end
  | ICall ->
    begin match s with
        SCons (v1, SCons (v0, s)) ->
        begin match v0 with
            VFun (i, vs) ->
            run_i10 i (SCons (VEnv (v1 :: vs), SCons (VK (c), s))) CNil t m
          | VCont (c', s', t') ->
            run_c10 c' (SCons (v1, s')) (apnd t' (cons c s t)) m
          | _ -> failwith ("not app " ^ to_string v0)
        end
      | _ -> failwith "stack error"
    end
  | IControl (i) ->
    begin match s with
        SCons (VEnv (vs), s) ->
        run_i10 i (SCons (VEnv (VCont (c, s, t) :: vs), SNil)) CNil TNil m
      | _ -> failwith "stack error"
    end
  | IPrompt (i) ->
    begin match s with
        SCons (VEnv (vs), s) ->
        run_i10 i (SCons (VEnv (vs), SNil)) CNil TNil ((c, s, t) :: m)
      | _ -> failwith "stack error"
    end
  | ISeq (i0, i1) -> run_i10 i0 s (CCons (i1, c)) t m

(* (>>) : i -> i -> i *)
let (>>) i0 i1 = ISeq (i0, i1)

(* f10 : e -> string list -> i *)
let rec f10 e xs = match e with
    Num (n) -> INum (VNum (n))
  | Var (x) -> IAccess (Env.offset x xs)
  | Op (e0, op, e1) ->
    IPush_env >> f10 e0 xs >> IPop_env >> f10 e1 xs >> (IOperations op)
  | Fun (x, e) -> IPush_closure (f10 e (x :: xs) >> IReturn)
  | App (e0, e1) ->
    IPush_env >> f10 e0 xs >> IPop_env >> f10 e1 xs >> ICall
  | Control (x, e) -> IControl (f10 e (x :: xs))
  | Prompt (e) -> IPrompt (f10 e xs)

(* f : e -> v *)
let f expr = run_i10 (f10 expr []) (SCons (VEnv ([]), SNil)) CNil TNil []