%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%

% This module defines the stuff for interpreting GML programs.

:- module eval.

:- interface.

:- import_module gml.
:- import_module trans.
:- import_module vector.

:- import_module array.
:- import_module bool.
:- import_module io.
:- import_module list.
:- import_module map.
:- import_module maybe.

:- type value
    % base values
    --->    boolean(bool)
    ;       int(int)
    ;       real(real)
    ;       string(string)
    % non-base values
    ;       closure(env, code)
    ;       array(array)
    ;       point(point)
    ;       object(object)
    ;       light(light).

:- type color == point. % components restricted to range [0.0, 1.0]

:- type array == array(value).

:- type light
    --->    directional(
                dir::vector,
                directional_intensity::color
            )
    ;       pointlight( % Tier 2
                pointlight_pos::position,
                pointlight_intensity::color
            )
    ;       spotlight(  % Tier 3
                spotlight_pos::position,
                at::position,
                spotlight_intensity::color,
                cutoff::degrees,
                exp::real
            ).

:- type degrees == real.

:- type object_id == int.

    % XXX this is very tentative
:- type object
    --->    basic_object(object_id, basic_object, list(light))

            % XXX should these be applied when they
            % are found, or done lazily.
    ;       transform(object, transformation)

    ;       union(object, object)
    ;       intersect(object, object)   % Tier 3
    ;       difference(object, object). % Tier 3

:- inst basic_object_inst for object/0 == bound( basic_object(ground, ground, ground)).

:- type basic_object
    --->    sphere(surface)
    ;       cube(surface)           % Tier 2
    ;       cylinder(surface)       % Tier 2
    ;       cone(surface)           % Tier 2
    ;       plane(surface).

:- type transformation
    --->    translate(tx::real, ty::real, tz::real)
    ;       scale(sx::real, sy::real, sz::real)
    ;       uscale(s::real)
    ;       rotatex(rotatex_theta::degrees)
    ;       rotatey(rotatey_theta::degrees)
    ;       rotatez(rotatez_theta::degrees)
    ;       matrix(trans).

:- type surface
    --->    surface(env, code)      % The surface function
    ;       constant(surface_properties).   % surface function is constant

:- type surface_properties
    --->    surface_properties(
                surface_c       :: color,
                surface_kd      :: real,     % diffuse reflection coeff
                surface_ks      :: real,     % specular reflection coeff
                surface_n       :: real      % Phong exp
            ).

:- type env == map(id, value).

:- type id == string.

:- type stack == list(value).

:- type code == token_list.

:- pred setup_and_interpret(code::in, io::di, io::uo) is det.

:- pred initial_setup(env::out, stack::out, global_object_counter::uo) is det.

:- pred interpret(code::in, env::in, env::out, stack::in, stack::out,
    global_object_counter::di, global_object_counter::uo) is det.

    % Some exceptions we might throw.
:- type stack_env_exception
    --->    stack_env_exception(string, env, stack).

:- type stack_env_token_exception
    --->    stack_env_token_exception(string, env, stack, token).

    % An error in the program itself.
:- type program_error
    --->    program_error(string)
    ;       program_error(string, stack).

    % Peephole needs this to build closures that do evaluation.
    %
:- func push(value, stack) = stack.
:- pred pop(stack::in, value::out, stack::out) is semidet.
:- pred eval_error(env::in, stack::in) is erroneous.

    % args(Op, In, Out):
    %
    % The number of args operator takes off the stack and Out
    % maybe holds the number of results the operator puts back
    % onto the stack.
    %
:- pred args(operator::in, int::out, maybe(int)::out) is det.

:- type global_object_counter
    --->    global_object_counter(int).

%-----------------------------------------------------------------------------%

:- implementation.

:- import_module globals.
:- import_module op.
:- import_module peephole.
:- import_module renderer.
:- import_module space_partition.
:- import_module transform_object.

:- import_module int.
:- import_module float.
:- import_module pair.
:- import_module exception.
:- import_module string.

setup_and_interpret(Code, !IO) :-
    initial_setup(Env0, Stack0, GOC),
    interpret(Code, Env0, _Env, Stack0, _Stack, GOC, _).

initial_setup(Env, [], global_object_counter(1)) :-
    map.init(Env).

interpret([], !Env, !Stack, !GOC).
interpret([Token | Tokens], !Env, !Stack, !GOC) :-
    do_token_group(Token, !Env, !Stack, !GOC),
    interpret(Tokens, !Env, !Stack, !GOC).

:- pred do_token_group(token_group::in, env::in, env::out,
    stack::in, stack::out,
    global_object_counter::di, global_object_counter::uo) is det.

do_token_group(single_token(Token), !Env, !Stack, !GOC) :-
    do_token(Token, !Env, !Stack, !GOC).
do_token_group(function(TokenList), !Env, !Stack, !GOC) :-
    % XXX this is only a win if a function gets invoked multiple times.
    % peephole(TokenList, OptTokenList),
    TokenList = OptTokenList,
    !:Stack = push(closure(!.Env, OptTokenList), !.Stack).
do_token_group(array(TokenList), !Env, !Stack, !GOC) :-
    interpret(TokenList, !.Env, _ResultEnv, empty_stack, ArrayStack, !GOC),
    !:Stack = push(array(array(reverse(ArrayStack))), !.Stack).

:- pred do_token(token::in, env::in, env::out, stack::in, stack::out,
    global_object_counter::di, global_object_counter::uo) is det.

do_token(operator(Operator), !Env, !Stack, !GOC) :-
    do_op(Operator, !.Env, !Stack, !GOC).
do_token(identifier(Id), !Env, !Stack, !GOC) :-
    ( map.search(!.Env, Id, Val) ->
        !:Stack = push(Val, !.Stack)
    ;
        throw(program_error("identifier `" ++ Id ++ "' is unknown"))
    ).
do_token(binder(Id), !Env, !Stack, !GOC) :-
    ( pop(!.Stack, Val, !:Stack) ->
        map.set(Id, Val, !Env)
        % XXX what if id is already bound?
        % is it right to just overwrite the old value?
        % XXX trd: I think so.  You can't rebind operators
        % but you can rebind other things.
    ;
        empty_stack(!.Env, !.Stack, binder(Id))
    ).
do_token(boolean(Bool), !Env, !Stack, !GOC) :-
    !:Stack = push(boolean(Bool), !.Stack).
do_token(number(integer(Int)), !Env, !Stack, !GOC) :-
    !:Stack = push(int(Int), !.Stack).
do_token(number(real(Real)), !Env, !Stack, !GOC) :-
    !:Stack = push(real(Real), !.Stack).
do_token(string(String), !Env, !Stack, !GOC) :-
    !:Stack = push(string(String), !.Stack).
do_token(extra(Operator), !Env, !Stack, !GOC) :-
    do_extra(Operator, !.Env, !Stack, !GOC).

%-----------------------------------------------------------------------------%

    % This predicate actually does I/O. However, it is called (indirectly,
    % through interpret) from renderer.m in contexts through which it is
    % difficult to add I/O states, so doing the I/O here via a trace goal
    % seems like the best compromise.
    %
:- pred do_op(operator::in, env::in, stack::in, stack::out,
    global_object_counter::di, global_object_counter::uo) is det.

do_op(acos, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1] ->
        Stack = push(real(op_acos(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(addi, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N2), int(N1) | Stack1] ->
        Stack = push(int(op_addi(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(addf, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N2), real(N1) | Stack1] ->
        Stack = push(real(op_addf(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(apply, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [closure(ClosureEnv, ClosureCode) | Stack1] ->
        interpret(ClosureCode, ClosureEnv, _ResultEnv, Stack1, Stack, !GOC)
    ;
        eval_error(Env, Stack0)
    ).
do_op(asin, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1] ->
        Stack = push(real(op_asin(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(clampf, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1] ->
        Stack = push(real(op_clampf(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(cone, Env, Stack0, Stack, !GOC) :- %Tier-2
    ( Stack0 = [closure(CEnv, CCode) | Stack1] ->
        next_object_id(Id, !GOC),
        Stack = push(object(basic_object(Id, cone(surface(CEnv, CCode)), [])),
            Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(cos, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1] ->
        Stack = push(real(op_cos(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(cube, Env, Stack0, Stack, !GOC) :- %Tier-2
    ( Stack0 = [closure(CEnv, CCode) | Stack1] ->
        next_object_id(Id, !GOC),
        Stack = push(object( basic_object(Id, cube(surface(CEnv, CCode)), [])),
            Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(cylinder, Env, Stack0, Stack, !GOC) :- %Tier-2
    ( Stack0 = [closure(CEnv, CCode) | Stack1] ->
        next_object_id(Id, !GOC),
        Stack = push(object(basic_object(Id, cylinder(surface(CEnv, CCode)),
            [])), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(difference, Env, Stack0, Stack, !GOC) :- %Tier-3
    ( Stack0 = [object(O2), object(O1) | Stack1] ->
        Stack = push(object(difference(O1, O2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(divi, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N2), int(N1) | Stack1], N2 \= 0 ->
        Stack = push(int(op_divi(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(divf, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N2), real(N1) | Stack1] ->
        Stack = push(real(op_divf(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(eqi, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N2), int(N1) | Stack1] ->
        Stack = push(boolean(op_eqi(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(eqf, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N2), real(N1) | Stack1] ->
        Stack = push(boolean(op_eqf(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(floor, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1] ->
        Stack = push(int(op_floor(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(frac, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1] ->
        Stack = push(real(op_frac(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(get, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(I), array(A) | Stack1], in_bounds(A, I) ->
        lookup(A, I, Val),
        Stack = push(Val, Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(getx, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [point(point(X,_Y,_Z)) | Stack1] ->
        Stack = push(real(X), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(gety, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [point(point(_X,Y,_Z)) | Stack1] ->
        Stack = push(real(Y), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(getz, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [point(point(_X,_Y,Z)) | Stack1] ->
        Stack = push(real(Z), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(if, Env, Stack0, Stack, !GOC) :-
    (
        Stack0 = [closure(CE2, CC2), closure(CE1, CC1), boolean(YesNo)
            | Stack1]
    ->
        (
            YesNo = yes,
            interpret(CC1, CE1, _ResultEnv, Stack1, Stack, !GOC)
        ;
            YesNo = no,
            interpret(CC2, CE2, _ResultEnv, Stack1, Stack, !GOC)
        )
    ;
        eval_error(Env, Stack0)
    ).
do_op(intersect, Env, Stack0, Stack, !GOC) :- %Tier-3
    ( Stack0 = [object(O2), object(O1) | Stack1] ->
        Stack = push(object(intersect(O1, O2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(length, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [array(A) | Stack1] ->
        size(A, Size),
        Stack = push(int(Size), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(lessi, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N2), int(N1) | Stack1] ->
        Stack = push(boolean(op_lessi(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(lessf, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N2), real(N1) | Stack1] ->
        Stack = push(boolean(op_lessf(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(light, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [point(Colour), point(Dir) | Stack1] ->
        Stack = push(light(directional(Dir, Colour)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(modi, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N2), int(N1) | Stack1] ->
        Stack = push(int(op_modi(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(muli, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N2), int(N1) | Stack1] ->
        Stack = push(int(op_muli(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(mulf, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N2), real(N1) | Stack1] ->
        Stack = push(real(op_mulf(N1, N2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(negi, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N) | Stack1] ->
        Stack = push(int(op_negi(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(negf, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1] ->
        Stack = push(real(op_negf(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(plane, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [closure(CEnv, CCode) | Stack1] ->
        next_object_id(Id, !GOC),
        Stack = push(object(basic_object(Id, plane(surface(CEnv, CCode)), [])),
            Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(point, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(Z), real(Y), real(X) | Stack1] ->
        Stack = push(point(point(X,Y,Z)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(pointlight, Env, Stack0, Stack, !GOC) :- %Tier-2
    ( Stack0 = [point(Colour), point(Pos) | Stack1] ->
        Stack = push(light(pointlight(Pos, Colour)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(real, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N) | Stack1] ->
        Stack = push(real(op_real(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(render, Env, Stack0, Stack, !GOC) :-
    (
        Stack0 = [string(File), int(Ht), int(Wid), real(FOV),
            int(Depth), object(Obj), array(Lights), point(Amb)
            | Stack1]
    ->
        Scene = create_scene(push_transformations(Obj)),
        Params = render_params(Amb, Lights, Scene, Depth,
            FOV, Wid, Ht, File),
        trace [io(!IO)] (
            render(Params, !IO)
        ),
        Stack = Stack1
    ;
        eval_error(Env, Stack0)
    ).
do_op(rotatex, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(Theta), object(Obj0) | Stack1] ->
        rename_object(Obj0, Obj, !GOC),
        Stack = push(object(transform(Obj, rotatex(Theta))), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(rotatey, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(Theta), object(Obj0) | Stack1] ->
        rename_object(Obj0, Obj, !GOC),
        Stack = push(object(transform(Obj, rotatey(Theta))), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(rotatez, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(Theta), object(Obj0) | Stack1] ->
        rename_object(Obj0, Obj, !GOC),
        Stack = push(object(transform(Obj, rotatez(Theta))), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(scale, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(Z), real(Y), real(X), object(Obj0) | Stack1] ->
        rename_object(Obj0, Obj, !GOC),
        Stack = push(object(transform(Obj, scale(X, Y, Z))), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(sin, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1] ->
        Stack = push(real(op_sin(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(sphere, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [closure(CEnv, CCode) | Stack1] ->
        next_object_id(Id, !GOC),
        Stack = push(object(basic_object(Id, sphere(surface(CEnv, CCode)),
            [])), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(spotlight, Env, Stack0, Stack, !GOC) :- %Tier-3
    (
        Stack0 = [real(Exp), real(Cutoff), point(Colour),
            point(At), point(Pos) | Stack1]
    ->
        Stack = push(light(spotlight(Pos, At, Colour, Cutoff, Exp)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(sqrt, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N) | Stack1], N >= 0.0 ->
        Stack = push(real(op_sqrt(N)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(subi, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [int(N2), int(N1) | Stack1] ->
        Stack = push(int(op_subi(N1, N2)), Stack1)
    ;
        empty_stack(Env, Stack0, operator(subi))
    ).
do_op(subf, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(N2), real(N1) | Stack1] ->
        Stack = push(real(op_subf(N1, N2)), Stack1)
    ;
        empty_stack(Env, Stack0, operator(subf))
    ).
do_op(translate, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(Z), real(Y), real(X), object(Obj0) | Stack1] ->
        rename_object(Obj0, Obj, !GOC),
        Stack = push(object(transform(Obj, translate(X, Y, Z))), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(union, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [object(O2), object(O1) | Stack1] ->
        Stack = push(object(union(O1, O2)), Stack1)
    ;
        eval_error(Env, Stack0)
    ).
do_op(uscale, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [real(S), object(Obj0) | Stack1] ->
        rename_object(Obj0, Obj, !GOC),
        Stack = push(object(transform(Obj, uscale(S))), Stack1)
    ;
        eval_error(Env, Stack0)
    ).

%-----------------------------------------------------------------------------%

    % Rename each of the basic objects in the structure.
    %
:- pred rename_object(object::in, object::out,
    global_object_counter::di, global_object_counter::uo) is det.

rename_object(Object0, Object, !GOC) :-
    (
        Object0 = basic_object(_, BasicObject, L),
        next_object_id(Id, !GOC),
        Object = basic_object(Id, BasicObject, L)
    ;
        Object0 = transform(Obj0, Trans),
        rename_object(Obj0, Obj, !GOC),
        Object = transform(Obj, Trans)
    ;
        Object0 = union(Left0, Right0),
        rename_object(Left0, Left, !GOC),
        rename_object(Right0, Right, !GOC),
        Object = union(Left, Right)
    ;
        Object0 = intersect(Left0, Right0),
        rename_object(Left0, Left, !GOC),
        rename_object(Right0, Right, !GOC),
        Object = intersect(Left, Right)
    ;
        Object0 = difference(Left0, Right0),
        rename_object(Left0, Left, !GOC),
        rename_object(Right0, Right, !GOC),
        Object = difference(Left, Right)
    ).

:- pred next_object_id(object_id::out,
    global_object_counter::di, global_object_counter::uo) is det.

next_object_id(Id, global_object_counter(Id), global_object_counter(Id + 1)).

%-----------------------------------------------------------------------------%

:- pred extra_operator_mode(extra_operator::in,
    extra_operator::out(extra_operator_inst)) is det.

:- pragma foreign_proc("C",
    extra_operator_mode(A::in, B::out(extra_operator_inst)),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    B = A
").

%-----------------------------------------------------------------------------%

:- pred do_extra(extra_operator::in, env::in, stack::in, stack::out,
    global_object_counter::di, global_object_counter::uo) is det.

do_extra(Extra0, Env, Stack0, Stack, !GOC) :-
    extra_operator_mode(Extra0, Extra),
    do_extra2(Extra, Env, Stack0, Stack, !GOC).

:- pragma inline(pred(do_extra2/6)).

:- pred do_extra2(extra_operator::in(extra_operator_inst), env::in,
    stack::in, stack::out,
    global_object_counter::di, global_object_counter::uo) is det.

% do_extra2(mercury_closure(C), Env, Stack0, Stack, !GOC) :-
%   C(Env, Stack0, _, Stack).

do_extra2(dup, Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [Head | Tail] ->
        Stack = [Head, Head | Tail]
    ;
        eval_error(Env, Stack0)
    ).
do_extra2(popn(N), Env, Stack0, Stack, !GOC) :-
    ( popn(N, Stack0, Stack1) ->
        Stack = Stack1
    ;
        eval_error(Env, Stack0)
    ).
do_extra2(constant_sphere(SurfaceProperties), _Env, Stack0, Stack, !GOC) :-
    next_object_id(Id, !GOC),
    Stack = push(object(
        basic_object(Id, sphere(constant(SurfaceProperties)), [])),
        Stack0).
do_extra2(constant_plane(SurfaceProperties), _Env, Stack0, Stack, !GOC) :-
    next_object_id(Id, !GOC),
    Stack = push(object(
        basic_object(Id, plane(constant(SurfaceProperties)), [])),
        Stack0).
do_extra2(constant_cone(SurfaceProperties), _Env, Stack0, Stack, !GOC) :-
    next_object_id(Id, !GOC),
    Stack = push(object(
        basic_object(Id, cone(constant(SurfaceProperties)), [])),
        Stack0).
do_extra2(constant_cube(SurfaceProperties), _Env, Stack0, Stack, !GOC) :-
    next_object_id(Id, !GOC),
    Stack = push(object(
        basic_object(Id, cube(constant(SurfaceProperties)), [])),
        Stack0).
do_extra2(constant_cylinder(SurfaceProperties), _Env, Stack0, Stack, !GOC) :-
    next_object_id(Id, !GOC),
    Stack = push(object(
        basic_object(Id, cylinder(constant(SurfaceProperties)), [])),
        Stack0).
do_extra2(constant_point(Point), _Env, Stack0, Stack, !GOC) :-
    Stack = push(point(Point), Stack0).
do_extra2(constant_if(C1, C2), Env, Stack0, Stack, !GOC) :-
    ( Stack0 = [boolean(YesNo) | Stack1] ->
        (
            YesNo = yes,
            Stack = push(C1, Stack1)
        ;
            YesNo = no,
            Stack = push(C2, Stack1)
        )
    ;
        eval_error(Env, Stack0)
    ).

%-----------------------------------------------------------------------------%

:- func create_surface_properties(float, float, float,
    float, float, float) = surface_properties.

create_surface_properties(R, G, B, Diffuse, Specular, Phong)
    = surface_properties(point(R, G, B), Diffuse, Specular, Phong).

%-----------------------------------------------------------------------------%

args(acos, 1, yes(1)).
args(addi, 2, yes(1)).
args(addf, 2, yes(1)).
args(apply, 1, no).     % XXX pd handle this differently!
args(asin, 1, yes(1)).
args(clampf, 1, yes(1)).
args(cone, 1, yes(1)).
args(cos, 1, yes(1)).
args(cube, 1, yes(1)).
args(cylinder, 1, yes(1)).
args(difference, 2, yes(1)).
args(divi, 2, yes(1)).
args(divf, 2, yes(1)).
args(eqi, 2, yes(1)).
args(eqf, 2, yes(1)).
args(floor, 1, yes(1)).
args(frac, 1, yes(1)).
args(get, 2, yes(1)).
args(getx, 1, yes(1)).
args(gety, 1, yes(1)).
args(getz, 1, yes(1)).
args(if, 3, no).        % XXX pd handle this differently
args(intersect, 2, yes(1)).
args(length, 1, yes(1)).
args(lessi, 2, yes(1)).
args(lessf, 2, yes(1)).
args(light, 2, yes(1)).
args(modi, 2, yes(1)).
args(muli, 2, yes(1)).
args(mulf, 2, yes(1)).
args(negi, 1, yes(1)).
args(negf, 1, yes(1)).
args(plane, 1, yes(1)).
args(point, 3, yes(1)).
args(pointlight, 2, yes(1)).
args(real, 1, yes(1)).
args(render, 8, yes(0)).    % XXX pd handle this specially.
args(rotatex, 2, yes(1)).
args(rotatey, 2, yes(1)).
args(rotatez, 2, yes(1)).
args(scale, 4, yes(1)).
args(sin, 1, yes(1)).
args(sphere, 1, yes(1)).
args(spotlight, 5, yes(1)).
args(sqrt, 1, yes(1)).
args(subi, 2, yes(1)).
args(subf, 2, yes(1)).
args(translate, 4, yes(1)).
args(union, 2, yes(1)).
args(uscale, 2, yes(1)).

%-----------------------------------------------------------------------------%

push(X, L) = [X | L].

pop([X|Xs], X, Xs).

    % pop n values of the stack and throw them away.
    %
:- pred popn(int::in, stack::in, stack::out) is semidet.

popn(N, Stack0, Stack) :-
    ( N =< 0 ->
        Stack = Stack0
    ;
        pop(Stack0, _, Stack1),
        popn(N - 1, Stack1, Stack)
    ).

:- func empty_stack = stack.

empty_stack = [].

%-----------------------------------------------------------------------------%

eval_error(Env, Stack) :-
    ( Stack = [] ->
        throw(stack_env_exception("empty stack during evaluation", Env, Stack))
    ;
        throw(program_error("type error during evalutation", Stack))
    ).

:- pred type_error is erroneous.

type_error :-
    throw("type error").

:- pred empty_stack(env::in, stack::in, token::in) is erroneous.

empty_stack(E, S, T) :-
    throw(stack_env_token_exception("empty stack", E, S, T)).

:- pred stub(env::in, stack::in, stack::out) is erroneous.

stub(E, S, S) :-
    throw(stack_env_exception("not yet implemented", E, S)).

%-----------------------------------------------------------------------------%

