[m-rev.] diff: update benchmark programs
Zoltan Somogyi
zs at csse.unimelb.edu.au
Tue Nov 11 13:15:35 AEDT 2008
benchmarks/icfp2000_par/main.m:
benchmarks/progs/icfp2000_par/renderer.m:
Allow the user to determine from the command line
- whether parallelize the work, and if so how many pieces to divide it
into, and
- whether to output the raw times for just the rendering, and if so
to what file.
Also allow the input file to be named on the command line *without*
redirection.
benchmarks/progs/icfp2000_par/Mmakefile:
Link the executable dynamically, since on my laptop a statically linked
executable crashes during startup, before it even enters main.
benchmarks/progs/icfp2000_par/*.m:
Convert this program to our current programming style.
benchmarks/progs/qsort/qsort_mt.m:
Add optional command line arguments that allow users
- to request that the sorting be repeated (to generate times that are
less susceptible to clock granularity effects), and
- to request that the raw times for the sorting itself be written out
to a specified file.
Add a shallow2 version of the accumulator quicksort, to parallel
the append quicksort.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing compress
cvs diff: Diffing icfp2000
cvs diff: Diffing icfp2000_par
Index: icfp2000_par/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/Mmakefile,v
retrieving revision 1.1
diff -u -b -r1.1 Mmakefile
--- icfp2000_par/Mmakefile 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/Mmakefile 10 Nov 2008 13:03:28 -0000
@@ -1,13 +1,17 @@
-MCFLAGS = -O6 --intermodule-optimization
+# MCFLAGS = -O6 --intermodule-optimization
+MCFLAGS =
CFLAGS = -DML_OMIT_MATH_DOMAIN_CHECKS
-include Mmake.params
# The executable that we ship as our final entry should be
# statically linked
-MLFLAGS = --static
+# MLFLAGS = --static
-MAIN_TARGET = main
+MAIN_TARGET = all
+
+all: main
+# test_trans does not compile
depend : main.depend
Index: icfp2000_par/eval.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/eval.m,v
retrieving revision 1.1
diff -u -b -r1.1 eval.m
--- icfp2000_par/eval.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/eval.m 10 Nov 2008 10:49:31 -0000
@@ -1,9 +1,23 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
% This module defines the stuff for interpreting GML programs.
:- module eval.
+
:- interface.
-:- import_module bool, list, array, io, map, maybe.
-:- import_module gml, trans, vector.
+
+:- 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
@@ -53,8 +67,7 @@
; union(object, object)
; intersect(object, object) % Tier 3
- ; difference(object, object) % Tier 3
- .
+ ; difference(object, object). % Tier 3
:- inst basic_object_inst == bound( basic_object(ground, ground, ground)).
@@ -72,15 +85,14 @@
; rotatex(rotatex_theta::degrees)
; rotatey(rotatey_theta::degrees)
; rotatez(rotatez_theta::degrees)
- ; matrix(trans)
- .
+ ; matrix(trans).
:- type surface
---> surface(env, code) % The surface function
; constant(surface_properties). % surface function is constant
-:- type surface_properties --->
- surface_properties(
+:- type surface_properties
+ ---> surface_properties(
surface_c :: color,
surface_kd :: real, % diffuse reflection coeff
surface_ks :: real, % specular reflection coeff
@@ -95,596 +107,590 @@
:- type code == token_list.
-:- pred interpret(code::in, io__state::di, io__state::uo) is det.
+:- 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, stack::in,
- env::out, stack::out,
+:- 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_exception
+ ---> stack_env_exception(string, env, stack).
-:- type stack_env_token_exception --->
- stack_env_token_exception(string, env, stack, token).
+:- 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)
+ % 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).
+:- type global_object_counter
+ ---> global_object_counter(int).
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module int, float, maybe, pair, exception, string.
-:- import_module transform_object, space_partition.
+
:- import_module globals.
-:- import_module renderer.
:- import_module op.
:- import_module peephole.
+:- import_module renderer.
+:- import_module space_partition.
+:- import_module transform_object.
-interpret(Code) -->
- { initial_setup(Env0, Stack0, GOC) },
- { interpret(Code, Env0, Stack0, _Env, _Stack, GOC, _) }.
+:- import_module int.
+:- import_module float.
+:- import_module maybe.
+:- 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, Env, Stack) --> [].
-interpret([Token|Tokens], Env0, Stack0, Env, Stack) -->
- do_token_group(Token, Env0, Stack0, Env1, Stack1),
- interpret(Tokens, Env1, Stack1, Env, Stack).
-
-:- pred do_token_group(token_group::in, env::in, stack::in,
- env::out, stack::out, global_object_counter::di,
- global_object_counter::uo) is det.
-
-do_token_group(single_token(Token), Env0, Stack0, Env, Stack) -->
- do_token(Token, Env0, Stack0, Env, Stack).
-do_token_group(function(TokenList), Env0, Stack0, Env, Stack) -->
- % XXX this is only a win if a function gets invoked
- % multiple times.
- % { peephole(TokenList, OptTokenList) },
- { (TokenList = OptTokenList) },
- { Stack = push(closure(Env0, OptTokenList), Stack0) },
- { Env = Env0 }.
-do_token_group(array(TokenList), Env0, Stack0, Env, Stack) -->
- interpret(TokenList, Env0, empty_stack, _ResultEnv, ArrayStack),
- { Stack = push(array(array(reverse(ArrayStack))), Stack0) },
- { Env = Env0 }.
-
-:- pred do_token(token::in, env::in, stack::in,
- env::out, stack::out, global_object_counter::di,
- global_object_counter::uo) is det.
-do_token(operator(Operator), Env0, Stack0, Env, Stack) -->
- { Env = Env0 },
- do_op(Operator, Env, Stack0, Stack).
-do_token(identifier(Id), Env0, Stack0, Env, Stack) -->
- (
- { map__search(Env0, Id, Val) }
- ->
- { Stack = push(Val, Stack0) },
- { Env = Env0 }
- ;
- { throw(program_error(string__append_list(
- ["identifier `", Id, "' is unknown"]))) }
- ).
-do_token(binder(Id), Env0, Stack0, Env, Stack) -->
- { pop(Stack0, Val, Stack1) ->
- Stack = Stack1,
- map__set(Env0, Id, Val, 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(!.Env, 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(Env0, Stack0, binder(Id))
- }.
-do_token(boolean(Bool), Env0, Stack0, Env, Stack) -->
- { Stack = push(boolean(Bool), Stack0) },
- { Env = Env0 }.
-do_token(number(integer(Int)), Env0, Stack0, Env, Stack) -->
- { Stack = push(int(Int), Stack0) },
- { Env = Env0 }.
-do_token(number(real(Real)), Env0, Stack0, Env, Stack) -->
- { Stack = push(real(Real), Stack0) },
- { Env = Env0 }.
-do_token(string(String), Env0, Stack0, Env, Stack) -->
- { Stack = push(string(String), Stack0) },
- { Env = Env0 }.
-do_token(extra(Operator), Env0, Stack0, Env, Stack) -->
- { Env = Env0 },
- do_extra(Operator, Env, Stack0, Stack).
+ % 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).
%-----------------------------------------------------------------------------%
-:- pred do_op(operator, env, stack, stack,
- global_object_counter, global_object_counter).
-:- mode do_op(in, in, in, out, di, uo) is det.
-
+ % 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) -->
- ( { Stack0 = [real(N) | Stack1] } ->
- { Stack = push(real(op_acos(N)), Stack1) }
+do_op(acos, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [real(N) | Stack1] ->
+ Stack = push(real(op_acos(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(addi, Env, Stack0, Stack) -->
- ( { Stack0 = [int(N2), int(N1) | Stack1] } ->
- { Stack = push(int(op_addi(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(addf, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N2), real(N1) | Stack1] } ->
- { Stack = push(real(op_addf(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(apply, Env, Stack0, Stack) -->
- ( { Stack0 = [closure(ClosureEnv, ClosureCode) | Stack1] } ->
- interpret(ClosureCode, ClosureEnv, Stack1,
- _ResultEnv, Stack)
+do_op(apply, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [closure(ClosureEnv, ClosureCode) | Stack1] ->
+ interpret(ClosureCode, ClosureEnv, _ResultEnv, Stack1, Stack, !GOC)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(asin, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N) | Stack1] } ->
- { Stack = push(real(op_asin(N)), Stack1) }
+do_op(asin, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [real(N) | Stack1] ->
+ Stack = push(real(op_asin(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(clampf, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N) | Stack1] } ->
- { Stack = push(real(op_clampf(N)), Stack1) }
+do_op(clampf, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [real(N) | Stack1] ->
+ Stack = push(real(op_clampf(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(cone, Env, Stack0, Stack) --> %Tier-2
- ( { Stack0 = [closure(CEnv, CCode) | Stack1] } ->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, cone(surface(CEnv, CCode)),
- [])),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(cos, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N) | Stack1] } ->
- { Stack = push(real(op_cos(N)), Stack1) }
+do_op(cos, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [real(N) | Stack1] ->
+ Stack = push(real(op_cos(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(cube, Env, Stack0, Stack) --> %Tier-2
- ( { Stack0 = [closure(CEnv, CCode) | Stack1] } ->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, cube(surface(CEnv, CCode)),
- [])),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(cylinder, Env, Stack0, Stack) --> %Tier-2
- ( { Stack0 = [closure(CEnv, CCode) | Stack1] } ->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, cylinder(surface(CEnv, CCode)),
- [])),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(difference, Env, Stack0, Stack) --> %Tier-3
- ( { Stack0 = [object(O2), object(O1) | Stack1] } ->
- { Stack = push(object(difference(O1, O2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(divi, Env, Stack0, Stack) -->
- ( { Stack0 = [int(N2), int(N1) | Stack1], N2 \= 0 } ->
- { Stack = push(int(op_divi(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(divf, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N2), real(N1) | Stack1] } ->
- { Stack = push(real(op_divf(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(eqi, Env, Stack0, Stack) -->
- ( { Stack0 = [int(N2), int(N1) | Stack1] } ->
- { Stack = push(boolean(op_eqi(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(eqf, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N2), real(N1) | Stack1] } ->
- { Stack = push(boolean(op_eqf(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(floor, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N) | Stack1] } ->
- { Stack = push(int(op_floor(N)), Stack1) }
+do_op(floor, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [real(N) | Stack1] ->
+ Stack = push(int(op_floor(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(frac, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N) | Stack1] } ->
- { Stack = push(real(op_frac(N)), Stack1) }
+do_op(frac, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [real(N) | Stack1] ->
+ Stack = push(real(op_frac(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(get, Env, Stack0, Stack) -->
- ( { Stack0 = [int(I), array(A) | Stack1], in_bounds(A, I) } ->
- { lookup(A, I, Val) },
- { Stack = push(Val, Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(getx, Env, Stack0, Stack) -->
- ( { Stack0 = [point(point(X,_Y,_Z)) | Stack1] } ->
- { Stack = push(real(X), Stack1) }
+do_op(getx, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [point(point(X,_Y,_Z)) | Stack1] ->
+ Stack = push(real(X), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(gety, Env, Stack0, Stack) -->
- ( { Stack0 = [point(point(_X,Y,_Z)) | Stack1] } ->
- { Stack = push(real(Y), Stack1) }
+do_op(gety, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [point(point(_X,Y,_Z)) | Stack1] ->
+ Stack = push(real(Y), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(getz, Env, Stack0, Stack) -->
- ( { Stack0 = [point(point(_X,_Y,Z)) | Stack1] } ->
- { Stack = push(real(Z), Stack1) }
+do_op(getz, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [point(point(_X,_Y,Z)) | Stack1] ->
+ Stack = push(real(Z), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(if, Env, Stack0, Stack) -->
- ( { Stack0 = [closure(CE2, CC2), closure(CE1, CC1), boolean(YesNo)
- | Stack1] } ->
+do_op(if, Env, Stack0, Stack, !GOC) :-
+ (
+ Stack0 = [closure(CE2, CC2), closure(CE1, CC1), boolean(YesNo)
+ | Stack1]
+ ->
(
- { YesNo = yes },
- interpret(CC1, CE1, Stack1, _ResultEnv, Stack)
+ YesNo = yes,
+ interpret(CC1, CE1, _ResultEnv, Stack1, Stack, !GOC)
;
- { YesNo = no },
- interpret(CC2, CE2, Stack1, _ResultEnv, Stack)
+ YesNo = no,
+ interpret(CC2, CE2, _ResultEnv, Stack1, Stack, !GOC)
)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(intersect, Env, Stack0, Stack) --> %Tier-3
- ( { Stack0 = [object(O2), object(O1) | Stack1] } ->
- { Stack = push(object(intersect(O1, O2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(length, Env, Stack0, Stack) -->
- ( { Stack0 = [array(A) | Stack1] } ->
- { size(A, Size) },
- { Stack = push(int(Size), Stack1) }
+do_op(length, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [array(A) | Stack1] ->
+ size(A, Size),
+ Stack = push(int(Size), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(lessi, Env, Stack0, Stack) -->
- ( { Stack0 = [int(N2), int(N1) | Stack1] } ->
- { Stack = push(boolean(op_lessi(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(lessf, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N2), real(N1) | Stack1] } ->
- { Stack = push(boolean(op_lessf(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(light, Env, Stack0, Stack) -->
- ( { Stack0 = [point(Colour), point(Dir) | Stack1] } ->
- { Stack = push(light(directional(Dir, Colour)), Stack1) }
+do_op(light, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [point(Colour), point(Dir) | Stack1] ->
+ Stack = push(light(directional(Dir, Colour)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(modi, Env, Stack0, Stack) -->
- ( { Stack0 = [int(N2), int(N1) | Stack1] } ->
- { Stack = push(int(op_modi(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(muli, Env, Stack0, Stack) -->
- ( { Stack0 = [int(N2), int(N1) | Stack1] } ->
- { Stack = push(int(op_muli(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(mulf, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N2), real(N1) | Stack1] } ->
- { Stack = push(real(op_mulf(N1, N2)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(negi, Env, Stack0, Stack) -->
- ( { Stack0 = [int(N) | Stack1] } ->
- { Stack = push(int(op_negi(N)), Stack1) }
+do_op(negi, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [int(N) | Stack1] ->
+ Stack = push(int(op_negi(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(negf, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N) | Stack1] } ->
- { Stack = push(real(op_negf(N)), Stack1) }
+do_op(negf, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [real(N) | Stack1] ->
+ Stack = push(real(op_negf(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(plane, Env, Stack0, Stack) -->
- ( { Stack0 = [closure(CEnv, CCode) | Stack1] } ->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, plane(surface(CEnv, CCode)),
- [])),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(point, Env, Stack0, Stack) -->
- ( { Stack0 = [real(Z), real(Y), real(X) | Stack1] } ->
- { Stack = push(point(point(X,Y,Z)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(pointlight, Env, Stack0, Stack) --> %Tier-2
- ( { Stack0 = [point(Colour), point(Pos) | Stack1] } ->
- { Stack = push(light(pointlight(Pos, Colour)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(real, Env, Stack0, Stack) -->
- ( { Stack0 = [int(N) | Stack1] } ->
- { Stack = push(real(op_real(N)), Stack1) }
+do_op(real, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [int(N) | Stack1] ->
+ Stack = push(real(op_real(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(render, Env, Stack0, Stack) -->
+do_op(render, Env, Stack0, Stack, !GOC) :-
(
- { Stack0 = [string(File), int(Ht), int(Wid), real(FOV),
+ Stack0 = [string(File), int(Ht), int(Wid), real(FOV),
int(Depth), object(Obj), array(Lights), point(Amb)
- | Stack1] }
+ | Stack1]
->
- { Scene = create_scene(push_transformations(Obj)) },
- { Params = render_params(Amb, Lights, Scene, Depth,
- FOV, Wid, Ht, File) },
- { trace [io(!IO)] (
+ 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 }
+ ),
+ Stack = Stack1
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(rotatex, Env, Stack0, Stack) -->
- ( { Stack0 = [real(Theta), object(Obj0) | Stack1] } ->
- renameObject(Obj0, Obj),
- { Stack = push(object(transform(Obj, rotatex(Theta))),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(rotatey, Env, Stack0, Stack) -->
- ( { Stack0 = [real(Theta), object(Obj0) | Stack1] } ->
- renameObject(Obj0, Obj),
- { Stack = push(object(transform(Obj, rotatey(Theta))),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(rotatez, Env, Stack0, Stack) -->
- ( { Stack0 = [real(Theta), object(Obj0) | Stack1] } ->
- renameObject(Obj0, Obj),
- { Stack = push(object(transform(Obj, rotatez(Theta))),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(scale, Env, Stack0, Stack) -->
- ( { Stack0 = [real(Z), real(Y), real(X), object(Obj0) | Stack1] } ->
- renameObject(Obj0, Obj),
- { Stack = push(object(transform(Obj, scale(X, Y, Z))),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(sin, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N) | Stack1] } ->
- { Stack = push(real(op_sin(N)), Stack1) }
+do_op(sin, Env, Stack0, Stack, !GOC) :-
+ ( Stack0 = [real(N) | Stack1] ->
+ Stack = push(real(op_sin(N)), Stack1)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
-do_op(sphere, Env, Stack0, Stack) -->
- ( { Stack0 = [closure(CEnv, CCode) | Stack1] } ->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, sphere(surface(CEnv, CCode)),
- [])),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(spotlight, Env, Stack0, Stack) --> %Tier-3
- ( { Stack0 = [ real(Exp), real(Cutoff), point(Colour),
- point(At), point(Pos) | Stack1] } ->
- { Stack = push(light(spotlight(Pos, At, Colour, Cutoff, Exp)),
- Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(sqrt, Env, Stack0, Stack) -->
- ( { Stack0 = [real(N) | Stack1], N >= 0.0 } ->
- { Stack = push(real(op_sqrt(N)), Stack1) }
+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) }
+ eval_error(Env, Stack0)
).
-do_op(subi, Env, Stack0, Stack) -->
- { Stack0 = [int(N2), int(N1) | Stack1] ->
+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) -->
- { Stack0 = [real(N2), real(N1) | Stack1] ->
+ ).
+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) -->
- ( { Stack0 = [real(Z), real(Y), real(X), object(Obj0) | Stack1] } ->
- renameObject(Obj0, Obj),
- { Stack = push(object(transform(Obj, translate(X, Y, Z))),
- Stack1) }
- ;
- { eval_error(Env, Stack0) }
- ).
-do_op(union, Env, Stack0, Stack) -->
- ( { Stack0 = [object(O2), object(O1) | Stack1] } ->
- { Stack = push(object(union(O1, O2)), Stack1) }
- ;
- { eval_error(Env, Stack0) }
- ).
-do_op(uscale, Env, Stack0, Stack) -->
- ( { Stack0 = [real(S), object(Obj0) | Stack1] } ->
- renameObject(Obj0, Obj),
- { Stack = push(object(transform(Obj, uscale(S))), Stack1) }
+ ).
+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) }
+ eval_error(Env, Stack0)
).
%-----------------------------------------------------------------------------%
% Rename each of the basic objects in the structure.
-:- pred renameObject(object::in, object::out, global_object_counter::di,
- global_object_counter::uo) is det.
+ %
+:- pred rename_object(object::in, object::out,
+ global_object_counter::di, global_object_counter::uo) is det.
-renameObject(basic_object(_, BasicObject,L), basic_object(Id,BasicObject,L)) -->
- next_object_id(Id).
-renameObject(transform(Obj0, Trans), transform(Obj, Trans)) -->
- renameObject(Obj0, Obj).
-renameObject(union(Left0, Right0), union(Left, Right)) -->
- renameObject(Left0, Left),
- renameObject(Right0, Right).
-renameObject(intersect(Left0, Right0), intersect(Left, Right)) -->
- renameObject(Left0, Left),
- renameObject(Right0, Right).
-renameObject(difference(Left0, Right0), difference(Left, Right)) -->
- renameObject(Left0, Left),
- renameObject(Right0, Right).
+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.
+:- 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)).
+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 promise_pure(extra_operator_mode/2).
:- pragma foreign_proc("C",
extra_operator_mode(A::in, B::out(extra_operator_inst)),
[will_not_call_mercury, thread_safe, promise_pure],
- "B = A").
+"
+ B = A
+").
%-----------------------------------------------------------------------------%
-:- pred do_extra(extra_operator, env, stack, stack,
- global_object_counter, global_object_counter).
-:- mode do_extra(in, in, in, out, di, uo) is det.
-do_extra(Extra0, Env, Stack0, Stack) -->
- { extra_operator_mode(Extra0, Extra) },
- do_extra2(Extra, Env, Stack0, Stack).
+:- 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(do_extra2/6).
-:- pred do_extra2(extra_operator, env, stack, stack,
- global_object_counter, global_object_counter).
-:- mode do_extra2(in(extra_operator_inst), in, in, out, di, uo) is det.
+:- 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) -->
+% do_extra2(mercury_closure(C), Env, Stack0, Stack, !GOC) :-
% C(Env, Stack0, _, Stack).
-do_extra2(dup, Env, Stack0, Stack) -->
- { Stack0 = [Head | Tail] ->
+
+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) -->
- { popn(N, Stack0, Stack1) ->
+ ).
+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) -->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, sphere(constant(SurfaceProperties)),
- [])),
- Stack0) }.
-do_extra2(constant_plane(SurfaceProperties), _Env, Stack0, Stack) -->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, plane(constant(SurfaceProperties)),
- [])),
- Stack0) }.
-do_extra2(constant_cone(SurfaceProperties), _Env, Stack0, Stack) -->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, cone(constant(SurfaceProperties)),
- [])),
- Stack0) }.
-do_extra2(constant_cube(SurfaceProperties), _Env, Stack0, Stack) -->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, cube(constant(SurfaceProperties)),
- [])),
- Stack0) }.
-do_extra2(constant_cylinder(SurfaceProperties), _Env, Stack0, Stack) -->
- next_object_id(Id),
- { Stack = push(object(
- basic_object(Id, cylinder(constant(SurfaceProperties)),
- [])),
- Stack0) }.
-do_extra2(constant_point(Point), _Env, Stack0, Stack) -->
- { Stack = push(point(Point), Stack0) }.
-do_extra2(constant_if(C1, C2), Env, Stack0, Stack) -->
- (
- { Stack0 = [boolean(YesNo) | Stack1] }
- ->
+ ).
+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 = yes,
+ Stack = push(C1, Stack1)
;
- { YesNo = no },
- { Stack = push(C2, Stack1) }
+ YesNo = no,
+ Stack = push(C2, Stack1)
)
;
- { eval_error(Env, Stack0) }
+ eval_error(Env, Stack0)
).
%-----------------------------------------------------------------------------%
@@ -755,7 +761,9 @@
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
@@ -764,35 +772,33 @@
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
- ))
+ 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, stack, token).
-:- mode empty_stack(in, in, in) 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, stack, stack).
-:- mode stub(in, in, out) is erroneous.
-stub(E, S, S) :- throw(stack_env_exception("not yet implemented", E, S)).
+:- pred stub(env::in, stack::in, stack::out) is erroneous.
+
+stub(E, S, S) :-
+ throw(stack_env_exception("not yet implemented", E, S)).
%-----------------------------------------------------------------------------%
Index: icfp2000_par/eval_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/eval_util.m,v
retrieving revision 1.1
diff -u -b -r1.1 eval_util.m
--- icfp2000_par/eval_util.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/eval_util.m 11 Nov 2008 00:05:44 -0000
@@ -1,146 +1,158 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
:- module eval_util.
:- interface.
-:- import_module io, univ.
-:- import_module eval, gml.
+:- import_module eval.
+:- import_module gml.
+
+:- import_module io.
+:- import_module univ.
-:- pred write_env(env::in, io__state::di, io__state::uo) is det.
-:- pred write_stack(stack::in, io__state::di, io__state::uo) is det.
+:- pred write_env(env::in, io::di, io::uo) is det.
+:- pred write_stack(stack::in, io::di, io::uo) is det.
-:- pred write_nice_exception(univ::in, io__state::di, io__state::uo) is det.
+:- pred write_nice_exception(univ::in, io::di, io::uo) is det.
-:- pred write_prog(int::in, gml_program::in,
- io__state::di, io__state::uo) is det.
+:- pred write_prog(int::in, gml_program::in, io::di, io::uo) is det.
-:- type unequal_stacks_exception --->
- unequal_stacks_exception(string, stack, stack).
+:- type unequal_stacks_exception
+ ---> unequal_stacks_exception(string, stack, stack).
:- implementation.
-:- import_module int, list, exception, map, string, gml.
+:- import_module gml.
+
+:- import_module exception.
+:- import_module int.
+:- import_module list.
+:- import_module map.
:- import_module pprint.
+:- import_module string.
-write_nice_exception(E) -->
- io__stderr_stream(StdErr),
- io__set_output_stream(StdErr, OldStream),
+write_nice_exception(E, !IO) :-
+ io.stderr_stream(StdErr, !IO),
+ io.set_output_stream(StdErr, OldStream, !IO),
(
- { univ_to_type(E, unequal_stacks_exception(Msg, Stack, Opt)) }
+ univ_to_type(E, unequal_stacks_exception(Msg, Stack, Opt))
->
- io__write_string("Exception: "),
- io__write_string(Msg),
- io__nl,
- io__write_string("Unoptimized "),
- write_stack(Stack),
- io__write_string("Optimized "),
- write_stack(Opt)
+ io.write_string("Exception: ", !IO),
+ io.write_string(Msg, !IO),
+ io.nl(!IO),
+ io.write_string("Unoptimized ", !IO),
+ write_stack(Stack, !IO),
+ io.write_string("Optimized ", !IO),
+ write_stack(Opt, !IO)
;
- { univ_to_type(E, stack_env_exception(Msg, Env, Stack)) }
+ univ_to_type(E, stack_env_exception(Msg, Env, Stack))
->
- io__write_string("Exception: "),
- io__write_string(Msg),
- io__nl,
- write_env(Env),
- write_stack(Stack)
+ io.write_string("Exception: ", !IO),
+ io.write_string(Msg, !IO),
+ io.nl(!IO),
+ write_env(Env, !IO),
+ write_stack(Stack, !IO)
;
- { univ_to_type(E,
- stack_env_token_exception(Msg, Env, Stack, Token)) }
+ univ_to_type(E,
+ stack_env_token_exception(Msg, Env, Stack, Token))
->
- io__write_string("Exception at token "),
- io__write(Token),
- io__write_string(" : "),
- io__write_string(Msg),
- io__nl,
- write_env(Env),
- write_stack(Stack)
+ io.write_string("Exception at token ", !IO),
+ io.write(Token, !IO),
+ io.write_string(" : ", !IO),
+ io.write_string(Msg, !IO),
+ io.nl(!IO),
+ write_env(Env, !IO),
+ write_stack(Stack, !IO)
;
- { univ_to_type(E, parse_error(Msg)) }
+ univ_to_type(E, parse_error(Msg))
->
- io__write_string("Parse error: "),
- io__write_string(Msg)
+ io.write_string("Parse error: ", !IO),
+ io.write_string(Msg, !IO)
;
- { univ_to_type(E, lexer_error(N, Msg)) }
+ univ_to_type(E, lexer_error(N, Msg))
->
- io__format("Line %d: lexical error: %s ", [i(N), s(Msg)])
+ io.format("Line %d: lexical error: %s ", [i(N), s(Msg)], !IO)
;
- { univ_to_type(E, program_error(Msg)) }
+ univ_to_type(E, program_error(Msg))
->
- io__write_string("Program error: "),
- io__write_string(Msg)
+ io.write_string("Program error: ", !IO),
+ io.write_string(Msg, !IO)
;
- { univ_to_type(E, program_error(Msg, Stack)) }
+ univ_to_type(E, program_error(Msg, Stack))
->
- io__write_string("Program error: "),
- io__write_string(Msg),
- io__nl,
- write_stack(Stack)
+ io.write_string("Program error: ", !IO),
+ io.write_string(Msg, !IO),
+ io.nl(!IO),
+ write_stack(Stack, !IO)
;
- { univ_to_type(E, S) }
+ univ_to_type(E, S)
->
- io__write_string("Error: "),
- io__write_string(S)
+ io.write_string("Error: ", !IO),
+ io.write_string(S, !IO)
;
- io__write(E)
+ io.write(E, !IO)
),
- io__nl,
- io__set_output_stream(OldStream, _).
-
+ io.nl(!IO),
+ io.set_output_stream(OldStream, _, !IO).
-write_env(Env) -->
- io__write_string("Environment:\n"),
- map__foldl(write_env_entry, Env).
-
-:- pred write_env_entry(id::in, value::in, io__state::di, io__state::uo) is det.
-write_env_entry(Id, Value) -->
- io__write_string(Id),
- io__write_string("\t: "),
- io__write(Value),
- io__nl.
-
-write_stack(Stack) -->
- io__write_string("Stack:\n"),
- list__foldl(write_stack_entry, Stack).
-
-:- pred write_stack_entry(value::in, io__state::di, io__state::uo) is det.
-write_stack_entry(Value) -->
- write(80, to_doc(3, Value)),
- io__nl.
+write_env(Env, !IO) :-
+ io.write_string("Environment:\n", !IO),
+ map.foldl(write_env_entry, Env, !IO).
+
+:- pred write_env_entry(id::in, value::in, io::di, io::uo) is det.
+
+write_env_entry(Id, Value, !IO) :-
+ io.write_string(Id, !IO),
+ io.write_string("\t: ", !IO),
+ io.write(Value, !IO),
+ io.nl(!IO).
+
+write_stack(Stack, !IO) :-
+ io.write_string("Stack:\n", !IO),
+ list.foldl(write_stack_entry, Stack, !IO).
+
+:- pred write_stack_entry(value::in, io::di, io::uo) is det.
+
+write_stack_entry(Value, !IO) :-
+ write(80, to_doc(3, Value), !IO),
+ io.nl(!IO).
%-----------------------------------------------------------------------------%
-write_prog(_, []) --> [].
-write_prog(Indent, [Group | Groups]) -->
- write_group(Indent, Group),
- io__nl,
- write_prog(Indent, Groups).
-
-:- pred write_group(int::in, token_group::in,
- io__state::di, io__state::uo) is det.
-
-write_group(Indent, single_token(SingleToken)) -->
- indent(Indent),
- write(SingleToken).
-write_group(Indent, function(List)) -->
- indent(Indent),
- io__write_string("{\n"),
- write_prog(Indent + 1, List),
- indent(Indent),
- io__write_string("}").
-write_group(Indent, array(List)) -->
- indent(Indent),
- io__write_string("[\n"),
- write_prog(Indent + 1, List),
- indent(Indent),
- io__write_string("]").
-
-:- pred indent(int::in, io__state::di, io__state::uo) is det.
-
-indent(Indent) -->
- ( { Indent = 0 } ->
- []
+write_prog(_, [], !IO).
+write_prog(Indent, [Group | Groups], !IO) :-
+ write_group(Indent, Group, !IO),
+ io.nl(!IO),
+ write_prog(Indent, Groups, !IO).
+
+:- pred write_group(int::in, token_group::in, io::di, io::uo) is det.
+
+write_group(Indent, single_token(SingleToken), !IO) :-
+ indent(Indent, !IO),
+ write(SingleToken, !IO).
+write_group(Indent, function(List), !IO) :-
+ indent(Indent, !IO),
+ io.write_string("{\n", !IO),
+ write_prog(Indent + 1, List, !IO),
+ indent(Indent, !IO),
+ io.write_string("}", !IO).
+write_group(Indent, array(List), !IO) :-
+ indent(Indent, !IO),
+ io.write_string("[\n", !IO),
+ write_prog(Indent + 1, List, !IO),
+ indent(Indent, !IO),
+ io.write_string("]", !IO).
+
+:- pred indent(int::in, io::di, io::uo) is det.
+
+indent(Indent, !IO) :-
+ ( Indent = 0 ->
+ true
;
- io__write_string(" "),
- indent(Indent - 1)
+ io.write_string(" ", !IO),
+ indent(Indent - 1, !IO)
).
%-----------------------------------------------------------------------------%
Index: icfp2000_par/globals.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/globals.m,v
retrieving revision 1.1
diff -u -b -r1.1 globals.m
--- icfp2000_par/globals.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/globals.m 10 Nov 2008 05:25:29 -0000
@@ -1,66 +1,62 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
:- module globals.
:- interface.
:- import_module io.
-:- pred init(io__state, io__state).
-:- mode init(di, uo) is det.
+:- pred init(io::di, io::uo) is det.
-:- pred get(T1, T2, io__state, io__state).
-:- mode get(in, out, di, uo) is det.
+:- pred get(T1::in, T2::out, io::di, io::uo) is det.
-:- pred set(T1, T2, io__state, io__state).
-:- mode set(in, in, di, uo) is det.
+:- pred set(T1::in, T2::in, io::di, io::uo) is det.
:- implementation.
-:- import_module map, require, string, std_util, univ.
-
-init-->
- { my_map_init(Map) },
- { type_to_univ(Map, UMap1) },
- { unsafe_promise_unique(UMap1, UMap) },
- io__set_globals(UMap).
-
-get(Name, Value) -->
- io__get_globals(UMap0),
- (
- { univ_to_type(UMap0, Map0) }
- ->
- (
- { map__search(Map0, univ(Name), UValue) }
- ->
- (
- { univ_to_type(UValue, Value0) }
- ->
- { Value = Value0 }
+:- import_module map.
+:- import_module require.
+:- import_module std_util.
+:- import_module string.
+:- import_module univ.
+
+init(!IO) :-
+ my_map_init(Map),
+ type_to_univ(Map, UMap1),
+ unsafe_promise_unique(UMap1, UMap),
+ io.set_globals(UMap, !IO).
+
+get(Name, Value, !IO) :-
+ io.get_globals(UMap0, !IO),
+ ( univ_to_type(UMap0, Map0) ->
+ ( map.search(Map0, univ(Name), UValue) ->
+ ( univ_to_type(UValue, Value0) ->
+ Value = Value0
;
- { error("globals: value has bad type") }
+ error("globals: value has bad type")
)
;
- { error("get: global not found") }
+ error("get: global not found")
)
;
- { error("globals: global store stuffed up") }
+ error("globals: global store stuffed up")
).
-set(Name, Value) -->
- io__get_globals(UMap0),
- (
- { univ_to_type(UMap0, Map0) }
- ->
- { type_to_univ(Value, UValue) },
- { map__set(Map0, univ(Name), UValue, Map) },
- { type_to_univ(Map, UMap1) },
- { unsafe_promise_unique(UMap1, UMap) },
- io__set_globals(UMap)
+set(Name, Value, !IO) :-
+ io.get_globals(UMap0, !IO),
+ ( univ_to_type(UMap0, Map0) ->
+ type_to_univ(Value, UValue),
+ map.set(Map0, univ(Name), UValue, Map),
+ type_to_univ(Map, UMap1),
+ unsafe_promise_unique(UMap1, UMap),
+ io.set_globals(UMap, !IO)
;
- { error("globals: global store stuffed up") }
+ error("globals: global store stuffed up")
).
:- pred my_map_init(map(univ, univ)::out) is det.
my_map_init(Map) :-
- map__init(Map).
-
+ map.init(Map).
Index: icfp2000_par/gml.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/gml.m,v
retrieving revision 1.1
diff -u -b -r1.1 gml.m
--- icfp2000_par/gml.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/gml.m 10 Nov 2008 05:55:37 -0000
@@ -1,10 +1,18 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
% This module defines the GML parser, lexer, and the parse tree
% data structure.
:- module gml.
:- interface.
-:- import_module list, io.
-:- import_module bool, vector.
+
+:- import_module vector.
+
+:- import_module bool.
+:- import_module io.
+:- import_module list.
%-----------------------------------------------------------------------------%
%
@@ -26,9 +34,8 @@
; number(number)
; string(string)
- % Not part of the spec
- % these are extra operators which make interpretation
- % more efficient.
+ % Not part of the spec; these are extra operators
+ % which make interpretation more efficient.
; extra(extra_operator).
:- type number
@@ -85,13 +92,13 @@
; subf
; translate
; union
- ; uscale
- .
+ ; uscale.
% New operators which are not defined as part of the spec.
% They can only be introduced by an optimization phase, and
% exist to make interpretation more efficient.
:- import_module eval.
+
:- type extra_operator
---> popn(int) % discard top n elements of stack
; dup % duplicate the topmost element
@@ -117,15 +124,9 @@
; constant_if(
value,
value
- )
+ ).
% XXX this is not used anywhere and gets in the way of parallelisation --pw
-% ; mercury_closure(
-% pred(env, stack,
-% env, stack,
-% io__state, io__state
-% )
-% )
- .
+% ; mercury_closure(pred(env, env, stack, stack, io, io)).
:- inst extra_operator_inst ==
bound( popn(ground)
@@ -137,12 +138,11 @@
; constant_cylinder(ground)
; constant_point(ground)
; constant_if(ground, ground)
-% ; mercury_closure(pred(in, in, out, out, di, uo) is det)
+% ; mercury_closure(pred(in, out, in, out, di, uo) is det)
).
% throws an exception if it gets an invalid token or I/O error
-:- pred tokenize(list(basic_token)::out, io__state::di, io__state::uo)
- is det.
+:- pred tokenize(list(basic_token)::out, io::di, io::uo) is det.
:- type lexer_error
---> lexer_error(int, string).
@@ -164,54 +164,57 @@
; function(token_list)
; array(token_list).
- % throws an exception if it gets a parse error
+ % Throws an exception if it gets a parse error.
+ %
:- pred parse(list(basic_token)::in, gml_program::out) is det.
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module char, exception, require, string.
-
-tokenize(Tokens) -->
- tokenize_2([], RevTokens),
- { list__reverse(RevTokens, Tokens) }.
+:- import_module char.
+:- import_module exception.
+:- import_module require.
+:- import_module string.
+
+tokenize(Tokens, !IO) :-
+ tokenize_2([], RevTokens, !IO),
+ list.reverse(RevTokens, Tokens).
:- pred tokenize_2(list(basic_token)::in, list(basic_token)::out,
- io__state::di, io__state::uo) is det.
+ io::di, io::uo) is det.
-tokenize_2(Tokens0, Tokens) -->
- skip_whitespace(FirstCharResult),
+tokenize_2(Tokens0, Tokens, !IO) :-
+ skip_whitespace(FirstCharResult, !IO),
(
- { FirstCharResult = ok(FirstChar) },
- get_token(FirstChar, Token),
- tokenize_2([Token | Tokens0], Tokens)
+ FirstCharResult = ok(FirstChar),
+ get_token(FirstChar, Token, !IO),
+ tokenize_2([Token | Tokens0], Tokens, !IO)
;
- { FirstCharResult = eof },
- { Tokens = Tokens0 }
+ FirstCharResult = eof,
+ Tokens = Tokens0
;
- { FirstCharResult = error(Error) },
- lexer_io_error(Error)
+ FirstCharResult = error(Error),
+ lexer_io_error(Error, !IO)
).
-:- pred skip_whitespace(io__result(char)::out,
- io__state::di, io__state::uo) is det.
+:- pred skip_whitespace(io.result(char)::out, io::di, io::uo) is det.
-skip_whitespace(FirstCharResult) -->
- lexer_read_char(CharResult0),
+skip_whitespace(FirstCharResult, !IO) :-
+ lexer_read_char(CharResult0, !IO),
(
- { CharResult0 = ok(FirstChar) },
- ( { FirstChar = '%' } ->
- skip_to_end_of_line,
- skip_whitespace(FirstCharResult)
- ; { lexer_is_whitespace(FirstChar) } ->
- skip_whitespace(FirstCharResult)
+ CharResult0 = ok(FirstChar),
+ ( FirstChar = '%' ->
+ skip_to_end_of_line(!IO),
+ skip_whitespace(FirstCharResult, !IO)
+ ; lexer_is_whitespace(FirstChar) ->
+ skip_whitespace(FirstCharResult, !IO)
;
- { FirstCharResult = CharResult0 }
+ FirstCharResult = CharResult0
)
;
- { CharResult0 = eof },
- { FirstCharResult = eof }
+ CharResult0 = eof,
+ FirstCharResult = eof
).
:- pred lexer_is_whitespace(char::in) is semidet.
@@ -223,68 +226,67 @@
lexer_is_whitespace('\f').
lexer_is_whitespace('\v').
-:- pred skip_to_end_of_line(io__state::di, io__state::uo) is det.
+:- pred skip_to_end_of_line(io::di, io::uo) is det.
-skip_to_end_of_line -->
- lexer_read_char(CharResult),
+skip_to_end_of_line(!IO) :-
+ lexer_read_char(CharResult, !IO),
(
- { CharResult = ok(Char) },
- ( { Char = '\n' } ->
- []
- ; { Char = '\v' } ->
- []
- ; { Char = '\f' } ->
- []
- ; { Char = '\r' } ->
- []
- ;
- skip_to_end_of_line
- )
- ;
- { CharResult = eof }
- ).
-
-:- pred get_token(char::in, basic_token::out,
- io__state::di, io__state::uo) is det.
-
-get_token(Char, Token) -->
- ( { special_token(Char, Token0) } ->
- { Token = Token0 }
- ; { Char = '"' } ->
- get_string([], String),
- { Token = token(string(String)) }
- ; { char__is_alpha(Char) } ->
- get_identifier([Char], Identifier),
- ( { Identifier = "true" } ->
- { Token = token(boolean(yes)) }
- ; { Identifier = "false" } ->
- { Token = token(boolean(no)) }
- ; { is_operator(Identifier, Operator) } ->
- { Token = token(operator(Operator)) }
+ CharResult = ok(Char),
+ ( Char = '\n' ->
+ true
+ ; Char = '\v' ->
+ true
+ ; Char = '\f' ->
+ true
+ ; Char = '\r' ->
+ true
+ ;
+ skip_to_end_of_line(!IO)
+ )
+ ;
+ CharResult = eof
+ ).
+
+:- pred get_token(char::in, basic_token::out, io::di, io::uo) is det.
+
+get_token(Char, Token, !IO) :-
+ ( special_token(Char, Token0) ->
+ Token = Token0
+ ; Char = '"' ->
+ get_string([], String, !IO),
+ Token = token(string(String))
+ ; char.is_alpha(Char) ->
+ get_identifier([Char], Identifier, !IO),
+ ( Identifier = "true" ->
+ Token = token(boolean(yes))
+ ; Identifier = "false" ->
+ Token = token(boolean(no))
+ ; is_operator(Identifier, Operator) ->
+ Token = token(operator(Operator))
;
- { Token = token(identifier(Identifier)) }
+ Token = token(identifier(Identifier))
)
- ; { Char = ('/') } ->
- get_identifier([], Identifier),
+ ; Char = ('/') ->
+ get_identifier([], Identifier, !IO),
(
- { is_operator(Identifier, _)
+ ( is_operator(Identifier, _)
; Identifier = "true"
; Identifier = "false"
- }
+ )
->
- error_rebind_operator(Identifier)
+ error_rebind_operator(Identifier, !IO)
;
- []
+ true
),
- { Token = token(binder(Identifier)) }
- ; { Char = ('-') } ->
- get_number([Char], Num),
- { Token = token(number(Num)) }
- ; { char__is_digit(Char) } ->
- get_number([Char], Num),
- { Token = token(number(Num)) }
+ Token = token(binder(Identifier))
+ ; Char = ('-') ->
+ get_number([Char], Num, !IO),
+ Token = token(number(Num))
+ ; char.is_digit(Char) ->
+ get_number([Char], Num, !IO),
+ Token = token(number(Num))
;
- lexer_unexpected_char(Char, "start of token")
+ lexer_unexpected_char(Char, "start of token", !IO)
).
:- pred special_token(char::in, basic_token::out) is semidet.
@@ -297,7 +299,7 @@
:- pred is_printable(char::in) is semidet.
is_printable(Char) :-
- ( char__is_alnum_or_underscore(Char)
+ ( char.is_alnum_or_underscore(Char)
; is_printable_2(Char)
).
@@ -395,255 +397,252 @@
is_operator("union", union).
is_operator("uscale", uscale).
-:- pred get_identifier(list(char)::in, string::out,
- io__state::di, io__state::uo) is det.
+:- pred get_identifier(list(char)::in, string::out, io::di, io::uo) is det.
-get_identifier(Chars, String) -->
- lexer_read_char(CharResult),
+get_identifier(Chars, String, !IO) :-
+ lexer_read_char(CharResult, !IO),
(
- { CharResult = ok(Char) },
+ CharResult = ok(Char),
(
- { char__is_alnum_or_underscore(Char)
+ ( char.is_alnum_or_underscore(Char)
; Char = ('-')
- }
+ )
->
- get_identifier([Char | Chars], String)
+ get_identifier([Char | Chars], String, !IO)
;
- io__putback_char(Char),
- { string__from_rev_char_list(Chars, String) }
+ io.putback_char(Char, !IO),
+ string.from_rev_char_list(Chars, String)
)
;
- { CharResult = eof },
- { string__from_rev_char_list(Chars, String) }
+ CharResult = eof,
+ string.from_rev_char_list(Chars, String)
).
-:- pred get_string(list(char)::in, string::out,
- io__state::di, io__state::uo) is det.
+:- pred get_string(list(char)::in, string::out, io::di, io::uo) is det.
-get_string(Chars, String) -->
- lexer_read_char(CharResult),
+get_string(Chars, String, !IO) :-
+ lexer_read_char(CharResult, !IO),
(
- { CharResult = ok(Char) },
- ( { Char = '"' } ->
- { string__from_rev_char_list(Chars, String) }
- ; { is_printable(Char) } ->
- get_string([Char | Chars], String)
+ CharResult = ok(Char),
+ ( Char = '"' ->
+ string.from_rev_char_list(Chars, String)
+ ; is_printable(Char) ->
+ get_string([Char | Chars], String, !IO)
;
- lexer_unexpected_char(Char, "string")
+ lexer_unexpected_char(Char, "string", !IO)
)
;
- { CharResult = eof },
- lexer_unexpected_eof("string constant")
+ CharResult = eof,
+ lexer_unexpected_eof("string constant", !IO)
).
-:- pred get_number(list(char), number, io__state, io__state).
-:- mode get_number(in, out, di, uo) is det.
+:- pred get_number(list(char)::in, number::out, io::di, io::uo) is det.
-get_number(Chars, Token) -->
- lexer_read_char(Result),
- ( { Result = eof },
- rev_char_list_to_int(Chars, 10, Token)
- ; { Result = ok(Char) },
- ( { char__is_digit(Char) } ->
- get_number([Char | Chars], Token)
- ; { Char = ('.') } ->
- get_int_dot(Chars, Token)
- ; { Char = 'e' ; Char = 'E' } ->
- get_float_exponent([Char | Chars], Token)
+get_number(Chars, Token, !IO) :-
+ lexer_read_char(Result, !IO),
+ (
+ Result = eof,
+ rev_char_list_to_int(Chars, 10, Token, !IO)
+ ;
+ Result = ok(Char),
+ ( char.is_digit(Char) ->
+ get_number([Char | Chars], Token, !IO)
+ ; Char = ('.') ->
+ get_int_dot(Chars, Token, !IO)
+ ; ( Char = 'e' ; Char = 'E' ) ->
+ get_float_exponent([Char | Chars], Token, !IO)
;
- io__putback_char(Char),
- rev_char_list_to_int(Chars, 10, Token)
+ io.putback_char(Char, !IO),
+ rev_char_list_to_int(Chars, 10, Token, !IO)
)
).
-:- pred get_int_dot(list(char), number, io__state, io__state).
-:- mode get_int_dot(in, out, di, uo) is det.
+:- pred get_int_dot(list(char)::in, number::out, io::di, io::uo) is det.
-get_int_dot(Chars, Token) -->
- lexer_read_char(Result),
- ( { Result = eof },
- io__putback_char('.'),
- rev_char_list_to_int(Chars, 10, Token)
- ; { Result = ok(Char) },
- ( { char__is_digit(Char) } ->
- get_float_decimals([Char, '.' | Chars], Token)
+get_int_dot(Chars, Token, !IO) :-
+ lexer_read_char(Result, !IO),
+ (
+ Result = eof,
+ io.putback_char('.', !IO),
+ rev_char_list_to_int(Chars, 10, Token, !IO)
;
- io__putback_char(Char),
- io__putback_char('.'),
- rev_char_list_to_int(Chars, 10, Token)
+ Result = ok(Char),
+ ( char.is_digit(Char) ->
+ get_float_decimals([Char, '.' | Chars], Token, !IO)
+ ;
+ io.putback_char(Char, !IO),
+ io.putback_char('.', !IO),
+ rev_char_list_to_int(Chars, 10, Token, !IO)
)
).
-
-:- pred get_float_decimals(list(char), number, io__state, io__state).
-:- mode get_float_decimals(in, out, di, uo) is det.
-
% we've read past the decimal point, so now get the decimals
+ %
+:- pred get_float_decimals(list(char)::in, number::out, io::di, io::uo) is det.
-get_float_decimals(Chars, Token) -->
- lexer_read_char(Result),
- ( { Result = eof },
- rev_char_list_to_float(Chars, Token)
- ; { Result = ok(Char) },
- ( { char__is_digit(Char) } ->
- get_float_decimals([Char | Chars], Token)
- ; { Char = 'e' ; Char = 'E' } ->
- get_float_exponent([Char | Chars], Token)
+get_float_decimals(Chars, Token, !IO) :-
+ lexer_read_char(Result, !IO),
+ (
+ Result = eof,
+ rev_char_list_to_float(Chars, Token, !IO)
+ ;
+ Result = ok(Char),
+ ( char.is_digit(Char) ->
+ get_float_decimals([Char | Chars], Token, !IO)
+ ; ( Char = 'e' ; Char = 'E' ) ->
+ get_float_exponent([Char | Chars], Token, !IO)
;
- io__putback_char(Char),
- rev_char_list_to_float(Chars, Token)
+ io.putback_char(Char, !IO),
+ rev_char_list_to_float(Chars, Token, !IO)
)
).
-:- pred get_float_exponent(list(char), number, io__state, io__state).
-:- mode get_float_exponent(in, out, di, uo) is det.
+:- pred get_float_exponent(list(char)::in, number::out, io::di, io::uo) is det.
-get_float_exponent(Chars, Token) -->
- lexer_read_char(Result),
- ( { Result = eof },
- rev_char_list_to_float(Chars, Token)
- ; { Result = ok(Char) },
- ( { Char = ('-') } ->
- get_float_exponent_2([Char | Chars], Token)
- ; { char__is_digit(Char) } ->
- get_float_exponent_3([Char | Chars], Token)
+get_float_exponent(Chars, Token, !IO) :-
+ lexer_read_char(Result, !IO),
+ (
+ Result = eof,
+ rev_char_list_to_float(Chars, Token, !IO)
;
- lexer_unexpected_char(Char, "float exponent")
+ Result = ok(Char),
+ ( Char = ('-') ->
+ get_float_exponent_2([Char | Chars], Token, !IO)
+ ; char.is_digit(Char) ->
+ get_float_exponent_3([Char | Chars], Token, !IO)
+ ;
+ lexer_unexpected_char(Char, "float exponent", !IO)
)
).
-:- pred get_float_exponent_2(list(char), number, io__state, io__state).
-:- mode get_float_exponent_2(in, out, di, uo) is det.
-
% we've read past the E signalling the start of the exponent -
% make sure that there's at least one digit following,
% and then get the remaining digits
+ %
+:- pred get_float_exponent_2(list(char)::in, number::out, io::di, io::uo)
+ is det.
-get_float_exponent_2(Chars, Token) -->
- lexer_read_char(Result),
- ( { Result = eof },
- lexer_unexpected_eof("float exponent")
- ; { Result = ok(Char) },
- ( { char__is_digit(Char) } ->
- get_float_exponent_3([Char | Chars], Token)
+get_float_exponent_2(Chars, Token, !IO) :-
+ lexer_read_char(Result, !IO),
+ (
+ Result = eof,
+ lexer_unexpected_eof("float exponent", !IO)
+ ;
+ Result = ok(Char),
+ ( char.is_digit(Char) ->
+ get_float_exponent_3([Char | Chars], Token, !IO)
;
- lexer_unexpected_char(Char, "float exponent")
+ lexer_unexpected_char(Char, "float exponent", !IO)
)
).
-:- pred get_float_exponent_3(list(char), number, io__state, io__state).
-:- mode get_float_exponent_3(in, out, di, uo) is det.
-
% we've read past the first digit of the exponent -
% now get the remaining digits
+ %
+:- pred get_float_exponent_3(list(char)::in, number::out, io::di, io::uo)
+ is det.
-get_float_exponent_3(Chars, Token) -->
- lexer_read_char(Result),
- ( { Result = eof },
- rev_char_list_to_float(Chars, Token)
- ; { Result = ok(Char) },
- ( { char__is_digit(Char) } ->
- get_float_exponent_3([Char | Chars], Token)
+get_float_exponent_3(Chars, Token, !IO) :-
+ lexer_read_char(Result, !IO),
+ (
+ Result = eof,
+ rev_char_list_to_float(Chars, Token, !IO)
+ ;
+ Result = ok(Char),
+ ( char.is_digit(Char) ->
+ get_float_exponent_3([Char | Chars], Token, !IO)
;
- io__putback_char(Char),
- rev_char_list_to_float(Chars, Token)
+ io.putback_char(Char, !IO),
+ rev_char_list_to_float(Chars, Token, !IO)
)
).
-:- pred rev_char_list_to_int(list(char), int, number, io__state, io__state).
-:- mode rev_char_list_to_int(in, in, out, di, uo) is det.
+:- pred rev_char_list_to_int(list(char)::in, int::in, number::out,
+ io::di, io::uo) is det.
-rev_char_list_to_int(RevChars, Base, Token) -->
- { string__from_rev_char_list(RevChars, String) },
- conv_string_to_int(String, Base, Token).
+rev_char_list_to_int(RevChars, Base, Token, !IO) :-
+ string.from_rev_char_list(RevChars, String),
+ conv_string_to_int(String, Base, Token, !IO).
-:- pred conv_string_to_int(string, int, number, io__state, io__state).
-:- mode conv_string_to_int(in, in, out, di, uo) is det.
+:- pred conv_string_to_int(string::in, int::in, number::out,
+ io::di, io::uo) is det.
-conv_string_to_int(String, Base, Token) -->
- ( { string__base_string_to_int(Base, String, Int) } ->
- { Token = integer(Int) }
+conv_string_to_int(String, Base, Token, !IO) :-
+ ( string.base_string_to_int(Base, String, Int) ->
+ Token = integer(Int)
;
- io__get_line_number(Line),
- { Msg = string__append_list(
- ["invalid int token `", String, "'"]) },
- { throw(lexer_error(Line, Msg)) }
+ io.get_line_number(Line, !IO),
+ Msg = "invalid int token `" ++ String ++ "'",
+ throw(lexer_error(Line, Msg))
).
-:- pred rev_char_list_to_float(list(char), number, io__state, io__state).
-:- mode rev_char_list_to_float(in, out, di, uo) is det.
+:- pred rev_char_list_to_float(list(char)::in, number::out,
+ io::di, io::uo) is det.
-rev_char_list_to_float(RevChars, Token) -->
- { string__from_rev_char_list(RevChars, String) },
- conv_to_float(String, Token).
+rev_char_list_to_float(RevChars, Token, !IO) :-
+ string.from_rev_char_list(RevChars, String),
+ conv_to_float(String, Token, !IO).
-:- pred conv_to_float(string, number, io__state, io__state).
-:- mode conv_to_float(in, out, di, uo) is det.
+:- pred conv_to_float(string::in, number::out, io::di, io::uo) is det.
-conv_to_float(String, Token) -->
- ( { string__to_float(String, Float) } ->
- { Token = real(Float) }
+conv_to_float(String, Token, !IO) :-
+ ( string.to_float(String, Float) ->
+ Token = real(Float)
;
- io__get_line_number(Line),
- { Msg = string__append_list(
- ["invalid float token `", String, "'"]) },
- { throw(lexer_error(Line, Msg)) }
+ io.get_line_number(Line, !IO),
+ Msg = "invalid float token `" ++ String ++ "'",
+ throw(lexer_error(Line, Msg))
).
%-----------------------------------------------------------------------------%
-:- pred lexer_read_char(io__result(char)::out(bound(ok(ground);eof)),
- io__state::di, io__state::uo) is det.
+:- pred lexer_read_char(io.result(char)::out(bound(ok(ground);eof)),
+ io::di, io::uo) is det.
-lexer_read_char(CharResult) -->
- io__read_char(CharResult0),
+lexer_read_char(CharResult, !IO) :-
+ io.read_char(CharResult0, !IO),
(
- { CharResult0 = ok(_) },
- { CharResult = CharResult0 }
+ CharResult0 = ok(_),
+ CharResult = CharResult0
;
- { CharResult0 = eof },
- { CharResult = CharResult0 }
+ CharResult0 = eof,
+ CharResult = CharResult0
;
- { CharResult0 = error(Error) },
- lexer_io_error(Error)
+ CharResult0 = error(Error),
+ lexer_io_error(Error, !IO)
).
%-----------------------------------------------------------------------------%
-:- pred lexer_unexpected_eof(string::in,
- io__state::di, io__state::uo) is erroneous.
+:- pred lexer_unexpected_eof(string::in, io::di, io::uo) is erroneous.
-lexer_unexpected_eof(Where) -->
- io__get_line_number(Line),
- { Msg = string__append("unexpected end-of-file in ", Where) },
- { throw(lexer_error(Line, Msg)) }.
-
-:- pred lexer_unexpected_char(char::in, string::in,
- io__state::di, io__state::uo) is erroneous.
-
-lexer_unexpected_char(Char, Where) -->
- io__get_line_number(Line),
- { Msg = string__append_list(
- ["unexpected character `",
- string__from_char_list([Char]), "' in ", Where]) },
- { throw(lexer_error(Line, Msg)) }.
-
-:- pred lexer_io_error(io__error::in,
- io__state::di, io__state::uo) is erroneous.
-
-lexer_io_error(Error) -->
- io__get_line_number(Line),
- { io__error_message(Error, Msg) },
- { throw(lexer_error(Line, Msg)) }.
-
-:- pred error_rebind_operator(string::in,
- io__state::di, io__state::uo) is erroneous.
-
-error_rebind_operator(Identifier) -->
- io__get_line_number(Line),
- { Msg = string__append_list(
- ["attempt to rebind operator `", Identifier, "'"]) },
- { throw(lexer_error(Line, Msg)) }.
+lexer_unexpected_eof(Where, !IO) :-
+ io.get_line_number(Line, !IO),
+ Msg = string.append("unexpected end-of-file in ", Where),
+ throw(lexer_error(Line, Msg)).
+
+:- pred lexer_unexpected_char(char::in, string::in, io::di, io::uo)
+ is erroneous.
+
+lexer_unexpected_char(Char, Where, !IO) :-
+ io.get_line_number(Line, !IO),
+ Msg = "unexpected character `" ++ string.from_char_list([Char]) ++ "'" ++
+ " in " ++ Where,
+ throw(lexer_error(Line, Msg)).
+
+:- pred lexer_io_error(io.error::in, io::di, io::uo) is erroneous.
+
+lexer_io_error(Error, !IO) :-
+ io.get_line_number(Line, !IO),
+ io.error_message(Error, Msg),
+ throw(lexer_error(Line, Msg)).
+
+:- pred error_rebind_operator(string::in, io::di, io::uo) is erroneous.
+
+error_rebind_operator(Identifier, !IO) :-
+ io.get_line_number(Line, !IO),
+ Msg = "attempt to rebind operator `" ++ Identifier ++ "'",
+ throw(lexer_error(Line, Msg)).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -653,18 +652,16 @@
parse_2(StopAt, Tokens, RemainingTokens, [], Program0),
(
RemainingTokens = []
- ->
- true
;
+ RemainingTokens = [_ | _],
throw(parse_error("tokens left over at end of parse"))
),
- list__reverse(Program0, Program).
+ list.reverse(Program0, Program).
:- type stop_at
---> eof
; end_array
- ; end_function
- .
+ ; end_function.
:- pred parse_2(stop_at::in, list(basic_token)::in, list(basic_token)::out,
gml_program::in, gml_program::out) is det.
@@ -689,7 +686,7 @@
;
Token = '[',
parse_2(end_array, Tokens, Tokens1, [], Array0),
- list__reverse(Array0, Array),
+ list.reverse(Array0, Array),
parse_2(StopAt, Tokens1, RemainingTokens,
[array(Array) | Prog0], Prog)
;
@@ -703,7 +700,7 @@
;
Token = '{',
parse_2(end_function, Tokens, Tokens1, [], Func0),
- list__reverse(Func0, Func),
+ list.reverse(Func0, Func),
parse_2(StopAt, Tokens1, RemainingTokens,
[function(Func) | Prog0], Prog)
;
@@ -715,4 +712,3 @@
throw(parse_error("'}' without preceding '{'"))
)
).
-
Index: icfp2000_par/main.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/main.m,v
retrieving revision 1.1
diff -u -b -r1.1 main.m
--- icfp2000_par/main.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/main.m 10 Nov 2008 13:04:05 -0000
@@ -1,36 +1,110 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
% The top-level
:- module main.
:- interface.
:- import_module io.
-:- pred main(io__state::di, io__state::uo) is cc_multi.
+:- pred main(io::di, io::uo) is cc_multi.
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module globals, gml, eval, eval_util, std_util, exception, peephole.
+
+:- import_module eval.
+:- import_module eval_util.
+:- import_module exception.
+:- import_module globals.
+:- import_module gml.
+:- import_module peephole.
+:- import_module renderer.
+
+:- import_module char.
+:- import_module getopt.
+:- import_module list.
+:- import_module map.
+:- import_module std_util.
:- import_module unit.
-main -->
- try_io(
- (pred(unit::out, di, uo) is det -->
- globals__init,
- tokenize(BasicTokens),
- { parse(BasicTokens, Program) },
- { peephole(Program, OptProgram) },
-% write_prog(0, OptProgram),
- interpret(OptProgram)
- ),
- ExceptionResult
- ),
+main(!IO) :-
+ io.command_line_arguments(AllArgs, !IO),
+ OptionOps = option_ops(short_option, long_option, option_defaults),
+ getopt.process_options(OptionOps, AllArgs, _OptionArgs, NonOptionArgs,
+ OptionResult),
+ (
+ OptionResult = ok(OptionTable),
+ getopt.lookup_int_option(OptionTable, target_parallelism,
+ TargetParallelism),
+ getopt.lookup_string_option(OptionTable, time_filename,
+ TimeFileName),
+ set_target_parallelism(TargetParallelism, !IO),
+ set_time_filename(TimeFileName, !IO),
+
(
- { ExceptionResult = exception(E) }
- ->
- write_nice_exception(E),
- io__set_exit_status(1)
+ NonOptionArgs = []
+ % Take input from stdin.
+ ;
+ NonOptionArgs = [FileName],
+ io.see(FileName, SeeResult, !IO),
+ (
+ SeeResult = ok
+ ;
+ SeeResult = error(Error),
+ io.error_message(Error, Msg),
+ io.write_string(Msg, !IO),
+ io.set_exit_status(1, !IO)
+ )
+ ;
+ NonOptionArgs = [_, _ | _],
+ io.write_string("Expected at most one non-option argument.\n", !IO)
+ ),
+
+ try_io(real_main, ExceptionResult, !IO),
+ ( ExceptionResult = exception(E) ->
+ write_nice_exception(E, !IO),
+ io.set_exit_status(1, !IO)
;
- []
+ true
+ )
+ ;
+ OptionResult = error(Msg),
+ io.write_string(Msg, !IO),
+ io.nl(!IO),
+ io.set_exit_status(1, !IO)
).
+:- pred real_main(unit::out, io::di, io::uo) is det.
+
+real_main(unit, !IO) :-
+ globals.init(!IO),
+ tokenize(BasicTokens, !IO),
+ parse(BasicTokens, Program),
+ peephole(Program, OptProgram),
+% write_prog(0, OptProgram, !IO),
+ setup_and_interpret(OptProgram, !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- type option
+ ---> target_parallelism
+ ; time_filename.
+
+:- pred short_option(char::in, option::out) is semidet.
+
+short_option('p', target_parallelism).
+short_option('f', time_filename).
+
+:- pred long_option(string::in, option::out) is semidet.
+
+long_option("target-parallelism", target_parallelism).
+long_option("time_filename", time_filename).
+
+:- pred option_defaults(option::out, option_data::out) is nondet.
+
+option_defaults(target_parallelism, int(0)).
+option_defaults(time_filename, string("")).
+
%-----------------------------------------------------------------------------%
Index: icfp2000_par/op.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/op.m,v
retrieving revision 1.1
diff -u -b -r1.1 op.m
--- icfp2000_par/op.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/op.m 10 Nov 2008 07:09:53 -0000
@@ -1,3 +1,7 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
:- module op.
:- interface.
@@ -34,7 +38,9 @@
:- implementation.
-:- import_module int, float, math.
+:- import_module float.
+:- import_module int.
+:- import_module math.
op_acos(N) = degrees(math__acos(N)).
op_addi(A, B) = A + B.
Index: icfp2000_par/peephole.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/peephole.m,v
retrieving revision 1.1
diff -u -b -r1.1 peephole.m
--- icfp2000_par/peephole.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/peephole.m 10 Nov 2008 06:16:50 -0000
@@ -1,3 +1,7 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
% main author: petdr
:- module peephole.
@@ -9,8 +13,20 @@
:- implementation.
-:- import_module eval, gml, op, vector.
-:- import_module bool, float, int, list, io, map, maybe, std_util, string.
+:- import_module eval.
+:- import_module gml.
+:- import_module op.
+:- import_module vector.
+
+:- import_module bool.
+:- import_module float.
+:- import_module int.
+:- import_module io.
+:- import_module list.
+:- import_module map.
+:- import_module maybe.
+:- import_module std_util.
+:- import_module string.
:- type peephole
---> state(
@@ -18,14 +34,14 @@
% used_ids :: list(string)
).
-peephole(Tokens0, list__reverse(Tokens)) :-
- peephole_2([], list__reverse(Tokens0), Tokens1,
- state(map__init), _),
+peephole(Tokens0, list.reverse(Tokens)) :-
+ peephole_2([], list.reverse(Tokens0), Tokens1, state(map.init), _),
Tokens = Tokens1.
-% peephole_2([], Tokens1, Tokens, state(map__init), _).
+% peephole_2([], Tokens1, Tokens, state(map.init), _).
% peephole_2(UsedIds, Code, OptCode)
+ %
% Given a piece of code which uses all the identifers,
% UsedIds, in the code located after Code generate some
% optimized code, OptCode. Note that the code is in
@@ -34,57 +50,48 @@
:- pred peephole_2(list(string)::in,
code::in, code::out, peephole::in, peephole::out) is det.
-peephole_2(_, [], []) --> [].
-peephole_2(UsedIds0, [Token | Tokens], NewTokens) -->
- { Token = single_token(_) },
- { UsedIds = used_ids([Token]) `list__append` UsedIds0 },
- peephole_2(UsedIds, Tokens, NewTokens0),
- ( peephole__match(UsedIds0, Token, NewTokens0, Result) ->
- { NewTokens = Result }
+peephole_2(_, [], [], !State).
+peephole_2(UsedIds0, [Token | Tokens], NewTokens, !State) :-
+ Token = single_token(_),
+ list.append(used_ids([Token]), UsedIds0, UsedIds),
+ peephole_2(UsedIds, Tokens, NewTokens0, !State),
+ ( peephole_match(UsedIds0, Token, NewTokens0, Result, !State) ->
+ NewTokens = Result
;
- { NewTokens = [Token | NewTokens0] }
+ NewTokens = [Token | NewTokens0]
).
-
-peephole_2(UsedIds0, [Token | Tokens], NewTokens) -->
- { Token = function(TokenList) },
- { UsedIds = used_ids(TokenList) `list__append` UsedIds0 },
- peephole_2(UsedIds, Tokens, NewTokens0),
+peephole_2(UsedIds0, [Token | Tokens], NewTokens, !State) :-
+ Token = function(TokenList),
+ list.append(used_ids(TokenList), UsedIds0, UsedIds),
+ peephole_2(UsedIds, Tokens, NewTokens0, !State),
% Process the function
- =(State),
- { peephole_2(UsedIds0, list__reverse(TokenList), OptTokenList,
- State, _) },
- { NewTokens = [function(list__reverse(OptTokenList)) | NewTokens0] }.
-
-peephole_2(UsedIds0, [Token | Tokens], NewTokens) -->
- { Token = array(TokenList) },
- { UsedIds = used_ids(TokenList) `list__append` UsedIds0 },
- peephole_2(UsedIds, Tokens, NewTokens0),
-
- % Process the array
- =(State),
- { peephole_2(UsedIds0, list__reverse(TokenList), OptTokenList,
- State, _) },
- { NewTokens = [array(list__reverse(OptTokenList)) | NewTokens0] }.
+ peephole_2(UsedIds0, list.reverse(TokenList), OptTokenList, !.State, _),
+ NewTokens = [function(list.reverse(OptTokenList)) | NewTokens0].
+peephole_2(UsedIds0, [Token | Tokens], NewTokens, !State) :-
+ Token = array(TokenList),
+ list.append(used_ids(TokenList), UsedIds0, UsedIds),
+ peephole_2(UsedIds, Tokens, NewTokens0, !State),
+ peephole_2(UsedIds0, list.reverse(TokenList), OptTokenList, !.State, _),
+ NewTokens = [array(list.reverse(OptTokenList)) | NewTokens0].
-:- pred peephole__insert(string::in, token_group::in,
+:- pred peephole_insert(string::in, token_group::in,
peephole::in, peephole::out) is det.
-peephole__insert(Id, Token, State0, State) :-
- State = State0 ^ known_ids :=
- map__set(State0 ^ known_ids, Id, Token).
+peephole_insert(Id, Token, !State) :-
+ !:State = !.State ^ known_ids := map.set(!.State ^ known_ids, Id, Token).
-:- pred peephole__delete(string::in, peephole::in, peephole::out) is det.
+:- pred peephole_delete(string::in, peephole::in, peephole::out) is det.
-peephole__delete(Id, State0, State) :-
- State = State0 ^ known_ids := map__delete(State0 ^ known_ids, Id).
+peephole_delete(Id, !State) :-
+ !:State = !.State ^ known_ids := map.delete(!.State ^ known_ids, Id).
-:- pred peephole__search(string::in, maybe(token_group)::out,
- peephole::in, peephole::out) is det.
+:- pred peephole_search(peephole::in, string::in, maybe(token_group)::out)
+ is det.
-peephole__search(Id, MaybeToken, State, State) :-
- ( map__search(State ^ known_ids, Id, Token) ->
+peephole_search(State, Id, MaybeToken) :-
+ ( map.search(State ^ known_ids, Id, Token) ->
MaybeToken = yes(Token)
;
MaybeToken = no
@@ -104,14 +111,12 @@
used_ids(Tokens)
).
used_ids([function(TokenList) | Tokens])
- = used_ids(TokenList) `list__append` used_ids(Tokens).
+ = used_ids(TokenList) `list.append` used_ids(Tokens).
used_ids([array(TokenList) | Tokens])
- = used_ids(TokenList) `list__append` used_ids(Tokens).
-
+ = used_ids(TokenList) `list.append` used_ids(Tokens).
%------------------------------------------------------------------------------%
- %
% Currently the following optimizations are performed:
% - constant propogation for all the numeric functions.
% - if branch condition is known remove untaken branch.
@@ -129,138 +134,135 @@
% versa
% - introduce Mercury closures for some important patterns
%
-:- pred peephole__match(list(string)::in, token_group::in, token_list::in,
+:- pred peephole_match(list(string)::in, token_group::in, token_list::in,
token_list::out, peephole::in, peephole::out) is semidet.
-
% If you see a function followed by apply, you can just run
% the function directly.
% This is turned off because we need to rename variables apart
% before we can use it. And 5:51am is not a good time to
% write variable renaming code. Come to think of it, there is
% no good time to write variable renaming code.
-peephole__match(_UsedIds, single_token(operator(apply)), Args, Result) -->
- { semidet_fail },
- { Args = [function(FunctionTokens) | Rest] },
- { Result = list__append(list__reverse(FunctionTokens), Rest) }.
-
- % Real/Integer constant propagation.
-peephole__match(_UsedIds, single_token(operator(acos)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { Result = [real_token(op_acos(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(addi)), Args, Result) -->
- { top_two_integer_args(Args, A, B, Rest) },
- { Result = [integer_token(op_addi(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(addf)), Args, Result) -->
- { top_two_real_args(Args, A, B, Rest) },
- { Result = [real_token(op_addf(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(asin)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { Result = [real_token(op_asin(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(clampf)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { Result = [real_token(op_clampf(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(cos)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { Result = [real_token(op_cos(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(divi)), Args, Result) -->
- { top_two_integer_args(Args, A, B, Rest) },
- { Result = [integer_token(op_divi(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(divf)), Args, Result) -->
+peephole_match(UsedIds, TokenGroup, Args, Result, !State) :-
(
- { top_two_real_args(Args, A, B, Rest) }
- ->
- { Result = [real_token(op_divf(A, B)) | Rest] }
+ TokenGroup = single_token(operator(apply)),
+ semidet_fail,
+ Args = [function(FunctionTokens) | Rest],
+ Result = list.append(list.reverse(FunctionTokens), Rest)
;
- { fail }
- ).
-
-peephole__match(_UsedIds, single_token(operator(eqi)), Args, Result) -->
- { top_two_integer_args(Args, A, B, Rest) },
- { Result = [boolean_token(op_eqi(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(eqf)), Args, Result) -->
- { top_two_real_args(Args, A, B, Rest) },
- { Result = [boolean_token(op_eqf(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(floor)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { Result = [integer_token(op_floor(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(frac)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { Result = [real_token(op_frac(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(lessi)), Args, Result) -->
- { top_two_integer_args(Args, A, B, Rest) },
- { Result = [boolean_token(op_lessi(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(lessf)), Args, Result) -->
- { top_two_real_args(Args, A, B, Rest) },
- { Result = [boolean_token(op_lessf(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(modi)), Args, Result) -->
- { top_two_integer_args(Args, A, B, Rest) },
- { Result = [integer_token(op_modi(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(muli)), Args, Result) -->
- { top_two_integer_args(Args, A, B, Rest) },
- { Result = [integer_token(op_muli(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(mulf)), Args, Result) -->
- { top_two_real_args(Args, A, B, Rest) },
- { Result = [real_token(op_mulf(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(negi)), Args, Result) -->
- { Args = [integer_token(A) | Rest] },
- { Result = [integer_token(op_negi(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(negf)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { Result = [real_token(op_negf(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(real)), Args, Result) -->
- { Args = [integer_token(A) | Rest] },
- { Result = [real_token(op_real(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(sin)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { Result = [real_token(op_sin(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(sqrt)), Args, Result) -->
- { Args = [real_token(A) | Rest] },
- { A >= 0.0 },
- { Result = [real_token(op_sqrt(A)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(subi)), Args, Result) -->
- { top_two_integer_args(Args, A, B, Rest) },
- { Result = [integer_token(op_subi(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(subf)), Args, Result) -->
- { top_two_real_args(Args, A, B, Rest) },
- { Result = [real_token(op_subf(A, B)) | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(if)), Args, Result) -->
- {
+ % Real/Integer constant propagation.
+ TokenGroup = single_token(operator(acos)),
+ Args = [real_token(A) | Rest],
+ Result = [real_token(op_acos(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(addi)),
+ top_two_integer_args(Args, A, B, Rest),
+ Result = [integer_token(op_addi(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(addf)),
+ top_two_real_args(Args, A, B, Rest),
+ Result = [real_token(op_addf(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(asin)),
+ Args = [real_token(A) | Rest],
+ Result = [real_token(op_asin(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(clampf)),
+ Args = [real_token(A) | Rest],
+ Result = [real_token(op_clampf(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(cos)),
+ Args = [real_token(A) | Rest],
+ Result = [real_token(op_cos(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(divi)),
+ top_two_integer_args(Args, A, B, Rest),
+ Result = [integer_token(op_divi(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(divf)),
+ ( top_two_real_args(Args, A, B, Rest) ->
+ Result = [real_token(op_divf(A, B)) | Rest]
+ ;
+ fail
+ )
+ ;
+ TokenGroup = single_token(operator(eqi)),
+ top_two_integer_args(Args, A, B, Rest),
+ Result = [boolean_token(op_eqi(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(eqf)),
+ top_two_real_args(Args, A, B, Rest),
+ Result = [boolean_token(op_eqf(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(floor)),
+ Args = [real_token(A) | Rest],
+ Result = [integer_token(op_floor(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(frac)),
+ Args = [real_token(A) | Rest],
+ Result = [real_token(op_frac(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(lessi)),
+ top_two_integer_args(Args, A, B, Rest),
+ Result = [boolean_token(op_lessi(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(lessf)),
+ top_two_real_args(Args, A, B, Rest),
+ Result = [boolean_token(op_lessf(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(modi)),
+ top_two_integer_args(Args, A, B, Rest),
+ Result = [integer_token(op_modi(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(muli)),
+ top_two_integer_args(Args, A, B, Rest),
+ Result = [integer_token(op_muli(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(mulf)),
+ top_two_real_args(Args, A, B, Rest),
+ Result = [real_token(op_mulf(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(negi)),
+ Args = [integer_token(A) | Rest],
+ Result = [integer_token(op_negi(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(negf)),
+ Args = [real_token(A) | Rest],
+ Result = [real_token(op_negf(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(real)),
+ Args = [integer_token(A) | Rest],
+ Result = [real_token(op_real(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(sin)),
+ Args = [real_token(A) | Rest],
+ Result = [real_token(op_sin(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(sqrt)),
+ Args = [real_token(A) | Rest],
+ A >= 0.0,
+ Result = [real_token(op_sqrt(A)) | Rest]
+ ;
+ TokenGroup = single_token(operator(subi)),
+ top_two_integer_args(Args, A, B, Rest),
+ Result = [integer_token(op_subi(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(subf)),
+ top_two_real_args(Args, A, B, Rest),
+ Result = [real_token(op_subf(A, B)) | Rest]
+ ;
+ TokenGroup = single_token(operator(if)),
+ (
% Branch reduction
- Args = [function(False), function(True),
- boolean_token(YesNo) | Rest]
+ Args = [function(False), function(True), boolean_token(YesNo)
+ | Rest]
->
(
YesNo = yes,
- Result = list__reverse(True)
- `list__append` Rest
+ list.append(list.reverse(True), Rest, Result)
;
YesNo = no,
- Result = list__reverse(False)
- `list__append` Rest
+ list.append(list.reverse(False), Rest, Result)
)
;
% If with constant args
@@ -270,58 +272,55 @@
constant_value(FalseConst, FalseValue),
constant_value(TrueConst, TrueValue)
->
- Result = [single_token(extra(
- constant_if(TrueValue, FalseValue))) | Rest]
+ Result = [single_token(extra(constant_if(TrueValue, FalseValue)))
+ | Rest]
;
fail
- }.
-
+ )
+ ;
% Removal of symbolic names, this should allow other
% optimizations to apply.
% Also if the identifier is unused we replace it with a popn(1)
% instruction.
-peephole__match(UsedIds, single_token(binder(Id)), Args, Result) -->
-
+ TokenGroup = single_token(binder(Id)),
% identifier followed by binder.
% this can't do anything.
- ( { Args = [single_token(identifier(Id)) | Rest] } ->
- { Result = Rest }
+ ( Args = [single_token(identifier(Id)) | Rest] ->
+ Result = Rest
;
- ( { list__member(Id, UsedIds) } ->
- { Args = [_ | Rest] },
- { chase_dups(Args, Bound) },
- ( { value_token_group(Bound) } ->
- { Result = Rest },
- peephole__insert(Id, Bound)
- ;
- % Delete the binding so we don't use an old
- % binding
- { Result = [single_token(binder(Id)) | Args] },
- peephole__delete(Id)
+ ( list.member(Id, UsedIds) ->
+ Args = [_ | Rest],
+ chase_dups(Args, Bound),
+ ( value_token_group(Bound) ->
+ Result = Rest,
+ peephole_insert(Id, Bound, !State)
+ ;
+ % Delete the binding so we don't use an old binding
+ Result = [single_token(binder(Id)) | Args],
+ peephole_delete(Id, !State)
)
;
% If the id is unused then replace it with a popn
% instruction, and then merge popn instructions.
- { NewToken = single_token(extra(popn(1))) },
- ( peephole__match(UsedIds, NewToken, Args, Result0) ->
- { Result = Result0 }
+ NewToken = single_token(extra(popn(1))),
+ ( peephole_match(UsedIds, NewToken, Args, Result0, !State) ->
+ Result = Result0
;
- { Result = [NewToken | Args] }
+ Result = [NewToken | Args]
)
)
- ).
-
-peephole__match(UsedIds, single_token(identifier(Id)), Args, Result) -->
- peephole__search(Id, MaybeNewToken),
- {
+ )
+ ;
+ TokenGroup = single_token(identifier(Id)),
+ peephole_search(!.State, Id, MaybeNewToken),
+ (
MaybeNewToken = yes(NewToken),
Result = [NewToken | Args]
;
MaybeNewToken = no,
(
- % often we have identifier(X) followed by
- % identifier(X) -- replace the duplicate with
- % a dup operation instead.
+ % often we have identifier(X) followed by identifier(X)
+ % -- replace the duplicate with a dup operation instead.
Args = [single_token(identifier(Id)) | Rest]
->
Result = [
@@ -335,7 +334,7 @@
% we can just eliminate it.
Args = [single_token(binder(Id)) | Rest]
->
- ( list__member(Id, UsedIds) ->
+ ( list.member(Id, UsedIds) ->
Result = [
single_token(binder(Id)),
single_token(extra(dup))
@@ -346,128 +345,123 @@
;
Result = [single_token(identifier(Id)) | Args]
)
- }.
-
-peephole__match(_UsedIds, single_token(extra(popn(N1))), Args, Result) -->
+ )
+ ;
+ TokenGroup = single_token(extra(popn(N1))),
(
% Merge popn instructions.
- { Args = [single_token(extra(popn(N2))) | Rest] }
+ Args = [single_token(extra(popn(N2))) | Rest]
->
- { Result = [single_token(extra(popn(N1 + N2))) | Rest] }
+ Result = [single_token(extra(popn(N1 + N2))) | Rest]
;
% Remove the code used to construct the value, which is
% popped off the stack if possible.
- { N1 = 1 },
- { remove_code_to_construct_one_value(Args, Rest) }
+ N1 = 1,
+ remove_code_to_construct_one_value(Args, Rest)
->
- { Result = Rest }
+ Result = Rest
+ ;
+ fail
+ )
;
- { fail }
- ).
-
% Recognise constant points
-peephole__match(_UsedIds, single_token(operator(point)), Args, Result) -->
- { top_three_real_args(Args, R, G, B, Rest) },
- { Point = point(R, G, B) },
- { Result = [single_token(extra(constant_point(Point))) | Rest ] }.
-
+ TokenGroup = single_token(operator(point)),
+ top_three_real_args(Args, R, G, B, Rest),
+ Point = point(R, G, B),
+ Result = [single_token(extra(constant_point(Point))) | Rest]
+ ;
% constant_point get functions
-peephole__match(_UsedIds, single_token(operator(getx)), Args, Result) -->
- { Args = [single_token(extra(constant_point(Point))) | Rest] },
- { Point = point(X, _Y, _Z) },
- { Result = [real_token(X) | Rest ] }.
-peephole__match(_UsedIds, single_token(operator(gety)), Args, Result) -->
- { Args = [single_token(extra(constant_point(Point))) | Rest] },
- { Point = point(_X, Y, _Z) },
- { Result = [real_token(Y) | Rest ] }.
-peephole__match(_UsedIds, single_token(operator(getz)), Args, Result) -->
- { Args = [single_token(extra(constant_point(Point))) | Rest] },
- { Point = point(_X, _Y, Z) },
- { Result = [real_token(Z) | Rest ] }.
-
-
+ TokenGroup = single_token(operator(getx)),
+ Args = [single_token(extra(constant_point(Point))) | Rest],
+ Point = point(X, _Y, _Z),
+ Result = [real_token(X) | Rest]
+ ;
+ TokenGroup = single_token(operator(gety)),
+ Args = [single_token(extra(constant_point(Point))) | Rest],
+ Point = point(_X, Y, _Z),
+ Result = [real_token(Y) | Rest]
+ ;
+ TokenGroup = single_token(operator(getz)),
+ Args = [single_token(extra(constant_point(Point))) | Rest],
+ Point = point(_X, _Y, Z),
+ Result = [real_token(Z) | Rest]
+ ;
% Constant surface functions.
-peephole__match(_UsedIds, single_token(operator(sphere)), Args, Result) -->
- { Args = [function(SurfaceFunc) | Rest] },
- {
- constant_surface_function(SurfaceFunc, SurfaceProperties)
- ->
+ TokenGroup = single_token(operator(sphere)),
+ Args = [function(SurfaceFunc) | Rest],
+ ( constant_surface_function(SurfaceFunc, SurfaceProperties) ->
ConstantObj = constant_sphere(SurfaceProperties),
- Result = [single_token(extra(ConstantObj)) | Rest ]
+ Result = [single_token(extra(ConstantObj)) | Rest]
;
Result = [single_token(operator(sphere)) | Args]
- }.
-
-peephole__match(_UsedIds, single_token(operator(plane)), Args, Result) -->
- { Args = [function(SurfaceFunc) | Rest] },
- {
- constant_surface_function(SurfaceFunc, SurfaceProperties)
- ->
+ )
+ ;
+ TokenGroup = single_token(operator(plane)),
+ Args = [function(SurfaceFunc) | Rest],
+ ( constant_surface_function(SurfaceFunc, SurfaceProperties) ->
ConstantObj = constant_plane(SurfaceProperties),
- Result = [single_token(extra(ConstantObj)) | Rest ]
+ Result = [single_token(extra(ConstantObj)) | Rest]
;
Result = [single_token(operator(plane)) | Args]
- }.
-
-peephole__match(_UsedIds, single_token(operator(cone)), Args, Result) -->
- { Args = [function(SurfaceFunc) | Rest] },
- {
- constant_surface_function(SurfaceFunc, SurfaceProperties)
- ->
+ )
+ ;
+ TokenGroup = single_token(operator(cone)),
+ Args = [function(SurfaceFunc) | Rest],
+ ( constant_surface_function(SurfaceFunc, SurfaceProperties) ->
ConstantObj = constant_cone(SurfaceProperties),
- Result = [single_token(extra(ConstantObj)) | Rest ]
+ Result = [single_token(extra(ConstantObj)) | Rest]
;
Result = [single_token(operator(cone)) | Args]
- }.
-
-peephole__match(_UsedIds, single_token(operator(cube)), Args, Result) -->
- { Args = [function(SurfaceFunc) | Rest] },
- {
- constant_surface_function(SurfaceFunc, SurfaceProperties)
- ->
+ )
+ ;
+ TokenGroup = single_token(operator(cube)),
+ Args = [function(SurfaceFunc) | Rest],
+ ( constant_surface_function(SurfaceFunc, SurfaceProperties) ->
ConstantObj = constant_cube(SurfaceProperties),
- Result = [single_token(extra(ConstantObj)) | Rest ]
+ Result = [single_token(extra(ConstantObj)) | Rest]
;
Result = [single_token(operator(cube)) | Args]
- }.
-
-peephole__match(_UsedIds, single_token(operator(cylinder)), Args, Result) -->
- { Args = [function(SurfaceFunc) | Rest] },
- {
- constant_surface_function(SurfaceFunc, SurfaceProperties)
- ->
+ )
+ ;
+ TokenGroup = single_token(operator(cylinder)),
+ Args = [function(SurfaceFunc) | Rest],
+ ( constant_surface_function(SurfaceFunc, SurfaceProperties) ->
ConstantObj = constant_cylinder(SurfaceProperties),
- Result = [single_token(extra(ConstantObj)) | Rest ]
+ Result = [single_token(extra(ConstantObj)) | Rest]
;
Result = [single_token(operator(cylinder)) | Args]
- }.
-
-peephole__match(_UsedIds, single_token(operator(get)), Args, Result) -->
- { semidet_fail },
- { Args = [integer_token(I), array(TokenList) | Rest] },
- { X = list__index0_det(TokenList, I) },
- { Result = [X | Rest] }.
-
-peephole__match(_UsedIds, single_token(operator(length)), Args, Result) -->
- { semidet_fail },
- { Args = [array(TokenList) | Rest] },
- { Result = [integer_token(list__length(TokenList)) | Rest] }.
-
+ )
+ ;
+ TokenGroup = single_token(operator(get)),
+ semidet_fail,
+ Args = [integer_token(I), array(TokenList) | Rest],
+ X = list__index0_det(TokenList, I),
+ Result = [X | Rest]
+ ;
+ TokenGroup = single_token(operator(length)),
+ semidet_fail,
+ Args = [array(TokenList) | Rest],
+ Result = [integer_token(list__length(TokenList)) | Rest]
+ ).
-:- pred constant_surface_function(code::in, surface_properties::out) is semidet.
+:- pred constant_surface_function(code::in, surface_properties::out)
+ is semidet.
constant_surface_function(SurfaceFunc, SurfaceProperties) :-
- SurfaceFunc = [ single_token(extra(popn(3))),
+ SurfaceFunc = [
+ single_token(extra(popn(3))),
single_token(extra(constant_point(Point))),
single_token(number(real(Diffuse))),
single_token(number(real(Specular))),
- single_token(number(real(Phong)))],
+ single_token(number(real(Phong)))
+ ],
SurfaceProperties = surface_properties(Point, Diffuse, Specular, Phong).
% Since id(N) id(N) is replaced by dup(N) id(N) we need to chase
% to the end of the dup instructions to see whether we can store
% the result in the state.
+ %
:- pred chase_dups(code::in, token_group::out) is semidet.
chase_dups([Token | Tokens], Bound) :-
@@ -476,8 +470,8 @@
;
value_token_group(Token),
Bound = Token
-
).
+
:- pred value_token_group(token_group::in) is semidet.
value_token_group(single_token(identifier(_))).
@@ -491,16 +485,16 @@
% value_token_group(single_token(extra(constant_sphere(_)))).
:- pred constant_value(token_group::in, value::out) is semidet.
+
constant_value(single_token(boolean(X)), boolean(X)).
constant_value(single_token(number(real(X))), real(X)).
constant_value(single_token(number(integer(X))), int(X)).
constant_value(single_token(string(X)), string(X)).
constant_value(single_token(extra(constant_point(P))), point(P)).
-
- % Remove code from the start of code list to construct one
- % value. Note we assume that the code list is in reverse order.
-
+ % Remove code from the start of code list to construct one value.
+ % Note we assume that the code list is in reverse order.
+ %
:- pred remove_code_to_construct_one_value(code::in, code::out) is semidet.
remove_code_to_construct_one_value([function(_) | Tokens], Tokens).
Index: icfp2000_par/ppm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/ppm.m,v
retrieving revision 1.1
diff -u -b -r1.1 ppm.m
--- icfp2000_par/ppm.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/ppm.m 10 Nov 2008 07:14:29 -0000
@@ -1,3 +1,7 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
%-----------------------------------------------------------------------------$
%
% Adapted from the following:
@@ -16,9 +20,11 @@
:- interface.
-:- import_module array, io.
:- import_module vector.
+:- import_module array.
+:- import_module io.
+
%-----------------------------------------------------------------------------%
%
@@ -31,74 +37,75 @@
% (and their value)
:- type image == array(point). % array of color values, indexed by Y * Width + X
-:- pred ppm__init(int, int, image).
-:- mode ppm__init(in, in, array_uo) is det.
-
-:- pred ppm__draw_image(string, int, int, image, io__state, io__state).
-:- mode ppm__draw_image(in, in, in, array_ui, di, uo) is det.
+ % Create the empty image buffer.
+ %
+:- pred ppm.init(int::in, int::in, image::array_uo) is det.
+
+ % Print out the header information for the PPM format, then output
+ % the image buffer.
+ %
+:- pred ppm.draw_image(string::in, int::in, int::in, image::array_ui,
+ io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module int, float, exception, require.
-
-% Create the empty image buffer
-ppm__init(Width, Height, Image) :-
- array__init(Width * Height, point(0.0, 0.0, 0.0), Image).
-
-% Print out the header information for the PPM format, then output the image
-% buffer.
-ppm__draw_image(FileName, Width, Height, Image) -->
- io__open_output(FileName, Result),
- ( { Result = ok(Stream) } ->
- io__set_output_stream(Stream, _Old),
- { private_builtin__unsafe_type_cast(Stream, BinStream) },
- io__set_binary_output_stream(BinStream, _OldBin),
- draw_image_2(Width, Height, Image)
+:- import_module exception.
+:- import_module float.
+:- import_module int.
+:- import_module require.
+
+ppm.init(Width, Height, Image) :-
+ array.init(Width * Height, point(0.0, 0.0, 0.0), Image).
+
+ppm.draw_image(FileName, Width, Height, Image, !IO) :-
+ io.open_output(FileName, Result, !IO),
+ ( Result = ok(Stream) ->
+ io.set_output_stream(Stream, _Old, !IO),
+ private_builtin.unsafe_type_cast(Stream, BinStream),
+ io.set_binary_output_stream(BinStream, _OldBin, !IO),
+ draw_image_2(Width, Height, Image, !IO)
;
- { throw(Result) }
+ throw(Result)
).
-:- pred ppm__draw_image_2(int, int, image, io__state, io__state).
-:- mode ppm__draw_image_2(in, in, array_ui, di, uo) is det.
-
-ppm__draw_image_2(Width, Height, Image) -->
- io__print("P6\n"),
- io__print("# Merry Mercurians\n"),
- io__print(Width), io__print(" "), io__print(Height), io__nl,
- io__print(255), io__nl,
- io__flush_output,
- do_image_draw(Width, Height, 0, 0, Image).
+:- pred ppm.draw_image_2(int::in, int::in, image::array_ui,
+ io::di, io::uo) is det.
+ppm.draw_image_2(Width, Height, Image, !IO) :-
+ io.print("P6\n", !IO),
+ io.print("# Merry Mercurians\n", !IO),
+ io.print(Width, !IO),
+ io.print(" ", !IO),
+ io.print(Height, !IO),
+ io.nl(!IO),
+ io.print(255, !IO),
+ io.nl(!IO),
+ io.flush_output(!IO),
+ do_image_draw(Width, Height, 0, 0, Image, !IO).
-:- pred do_image_draw(int, int, int, int, image, io__state, io__state).
-:- mode do_image_draw(in, in, in, in, in, di, uo) is det.
+:- pred do_image_draw(int::in, int::in, int::in, int::in, image::in,
+ io::di, io::uo) is det.
% Output the image buffer in binary format. There are three bytes for every
% pixel (Red, Green, Blue). These bytes are just streamed to stdout.
-do_image_draw(Width, Height, X, Y, Image) -->
- (
- { Y < Height }
- ->
- (
- { X < Width }
- ->
- { array__lookup(Image, (Y * Width) + X, Point) },
- { Point = point(R0, G0, B0),
+do_image_draw(Width, Height, X, Y, Image, !IO) :-
+ ( Y < Height ->
+ ( X < Width ->
+ array__lookup(Image, (Y * Width) + X, Point),
+ Point = point(R0, G0, B0),
R = round_to_int(R0 * 255.0),
G = round_to_int(G0 * 255.0),
- B = round_to_int(B0 * 255.0)
- },
- io__write_byte(R),
- io__write_byte(G),
- io__write_byte(B),
- do_image_draw(Width, Height, X + 1, Y, Image)
+ B = round_to_int(B0 * 255.0),
+ io__write_byte(R, !IO),
+ io__write_byte(G, !IO),
+ io__write_byte(B, !IO),
+ do_image_draw(Width, Height, X + 1, Y, Image, !IO)
;
- do_image_draw(Width, Height, 0, Y + 1, Image)
+ do_image_draw(Width, Height, 0, Y + 1, Image, !IO)
)
;
- % The empty list is used to represent an empty clause in a DCG
- []
+ true
).
Index: icfp2000_par/precompute_lights.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/precompute_lights.m,v
retrieving revision 1.1
diff -u -b -r1.1 precompute_lights.m
--- icfp2000_par/precompute_lights.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/precompute_lights.m 10 Nov 2008 08:01:23 -0000
@@ -1,54 +1,69 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
:- module precompute_lights.
% add information to the scene structure indicating which object/light pairs
% are guaranteed not to need shadow calculations. Blame pde & rejj.
:- interface.
+
+:- import_module eval.
+:- import_module space_partition.
+:- import_module vector.
+
:- import_module list.
-:- import_module space_partition, eval, vector.
-:- type bounding_sphere ---> bsphere(centre::point, radius::real).
+:- type bounding_sphere
+ ---> bsphere(centre::point, radius::real).
% scene_list : take a composite scene, return a list of the bounding
% boxes for objects inside it.
-:- pred scene_list(scene, list(bounding_sphere)).
-:- mode scene_list(in, out) is det.
+:- pred scene_list(scene::in, list(bounding_sphere)::out) is det.
% pre_compute_lighting calculates the "cleanly illuminated" (ie no chance of
% any shadows) light list for every basic object in the scene
-:- pred pre_compute_lighting(scene, list(bounding_sphere), list(light), scene).
-:- mode pre_compute_lighting(in, in, in, out) is det.
-
+:- pred pre_compute_lighting(scene::in, list(bounding_sphere)::in,
+ list(light)::in, scene::out) is det.
%------------------------------------------------------------------------------%
+
:- implementation.
-:- import_module std_util, exception, float, int, maybe, pair.
-:- import_module space_partition, renderer.
+:- import_module renderer.
+:- import_module space_partition.
+
+:- import_module exception.
+:- import_module float.
+:- import_module int.
+:- import_module maybe.
+:- import_module pair.
+:- import_module std_util.
+
%------------------------------------------------------------------------------%
-% X_list - these functions go through an X, and return a list of all the objects
-% therein
+% X_list - these functions go through an X,
+% and return a list of all the objects therein
% top level scene -> object list function
scene_list(scene(Part, Objs), List) :-
- list__map(object_list, Objs, Tmp),
- list__condense(Tmp, L1),
+ list.map(object_list, Objs, Tmp),
+ list.condense(Tmp, L1),
partition_list(Part, L2),
- List = list__append(L1, L2).
+ List = list.append(L1, L2).
% now iterate down the partition tree looking for objects
-:- pred partition_list(space_tree, list(bounding_sphere)).
-:- mode partition_list(in, out) is det.
+:- pred partition_list(space_tree::in, list(bounding_sphere)::out) is det.
partition_list(space_tree(_Pt, _N, Nodes), List) :-
- list__map(space_tree_node_list, Nodes, ObjectLists),
+ list.map(space_tree_node_list, Nodes, ObjectLists),
List = condense(ObjectLists).
-:- pred space_tree_node_list(space_tree_node::in,
- list(bounding_sphere)::out) is det.
+:- pred space_tree_node_list(space_tree_node::in, list(bounding_sphere)::out)
+ is det.
space_tree_node_list(Node, List) :-
(
@@ -63,42 +78,43 @@
%------------------------------------------------------------------------------%
% okay - we've got to the object tree; just flatten it into a list
-:- pred object_list(object, list(bounding_sphere)).
-:- mode object_list(in, out) is det.
+:- pred object_list(object::in, list(bounding_sphere)::out) is det.
-object_list(Obj,[BS]):-
+object_list(Obj, BSList) :-
+ (
Obj = basic_object(_, _, _),
Box = find_object_bounding_box(Obj),
- BS = bounding_sphere(Box).
-
-object_list(union(Object1, Object2), BSList) :-
+ BS = bounding_sphere(Box),
+ BSList = [BS]
+ ;
+ Obj = union(Object1, Object2),
object_list(Object1, BSList1),
object_list(Object2, BSList2),
- list__append(BSList1, BSList2, BSList).
-
-object_list(intersect(Object1, Object2), BSList) :-
+ list.append(BSList1, BSList2, BSList)
+ ;
+ Obj = intersect(Object1, Object2),
object_list(Object1, BSList1),
object_list(Object2, BSList2),
- list__append(BSList1, BSList2, BSList).
-
-object_list(difference(Object1, Object2), BSList) :-
+ list.append(BSList1, BSList2, BSList)
+ ;
+ Obj = difference(Object1, Object2),
object_list(Object1, BSList1),
object_list(Object2, BSList2),
- list__append(BSList1, BSList2, BSList).
-
-% handle a transform applied to a basic object
-
-object_list(transform(Obj, Trans), [BS]) :-
- Obj = basic_object(_, _, _),
- Box0 = find_object_bounding_box(Obj),
+ list.append(BSList1, BSList2, BSList)
+ ;
+ Obj = transform(SubObj, Trans),
+ ( SubObj = basic_object(_, _, _) ->
+ % handle a transform applied to a basic object
+ Box0 = find_object_bounding_box(SubObj),
Trans2 = maybe_transformation_to_trans(yes(Trans)),
Box = transform_bounding_box(Box0, Trans2),
- BS = bounding_sphere(Box).
-
-% choke on complex transforms
-
-object_list(transform(_ComplexObj,_Trans), []) :-
- throw("object_list can't handle complex transform objects!").
+ BS = bounding_sphere(Box),
+ BSList = [BS]
+ ;
+ % choke on complex transforms
+ throw("object_list can't handle complex transform objects!")
+ )
+ ).
%------------------------------------------------------------------------------%
@@ -108,17 +124,16 @@
% top level scene rebuilder
pre_compute_lighting(scene(Part, Objs), BSList, Lights, NewScene) :-
traverse_part(Part, BSList, Lights, NewPart),
- list__map(traverse_objects(BSList, Lights), Objs, NewObjs),
+ list.map(traverse_objects(BSList, Lights), Objs, NewObjs),
NewScene = scene(NewPart, NewObjs).
% rebuild the partition tree
-:- pred traverse_part(space_tree, list(bounding_sphere),
- list(light), space_tree).
-:- mode traverse_part(in, in, in, out) is det.
+:- pred traverse_part(space_tree::in, list(bounding_sphere)::in,
+ list(light)::in, space_tree::out) is det.
traverse_part(space_tree(Box, Area, Nodes0), BSList, Lights,
space_tree(Box, Area, Nodes)) :-
- list__map(
+ list.map(
(pred(Node0::in, Node::out) is det :-
(
Node0 = leaf(space_tree_object(A, B, Obj0)),
@@ -135,60 +150,54 @@
% rebuild an object tree
-:- pred traverse_objects(list(bounding_sphere), list(light), object, object).
-:- mode traverse_objects(in, in, in, out) is det.
+:- pred traverse_objects(list(bounding_sphere)::in, list(light)::in,
+ object::in, object::out) is det.
traverse_objects(BSList, Lights, Obj, NewObject) :-
+ (
Obj = basic_object(_, _, _),
- calc_light_list(Obj, no, BSList, Lights, NewObject).
-
-traverse_objects(BSList, Lights, union(Obj1, Obj2), NewObject) :-
+ calc_light_list(Obj, no, BSList, Lights, NewObject)
+ ;
+ Obj = union(Obj1, Obj2),
traverse_objects(BSList, Lights, Obj1, NewObject1),
traverse_objects(BSList, Lights, Obj2, NewObject2),
- NewObject = union(NewObject1, NewObject2).
-
-traverse_objects(BSList, Lights, intersect(Obj1, Obj2), NewObject) :-
+ NewObject = union(NewObject1, NewObject2)
+ ;
+ Obj = intersect(Obj1, Obj2),
traverse_objects(BSList, Lights, Obj1, NewObject1),
traverse_objects(BSList, Lights, Obj2, NewObject2),
- NewObject = intersect(NewObject1, NewObject2).
-
-traverse_objects(BSList, Lights, difference(Obj1, Obj2), NewObject) :-
+ NewObject = intersect(NewObject1, NewObject2)
+ ;
+ Obj = difference(Obj1, Obj2),
traverse_objects(BSList, Lights, Obj1, NewObject1),
traverse_objects(BSList, Lights, Obj2, NewObject2),
- NewObject = difference(NewObject1, NewObject2).
-
-% The only kind of transform we can handle is one wrapping a basic object
-
-traverse_objects( BSList, Lights, transform(Obj, Trans), NewObject) :-
- Obj = basic_object(_, _, _),
- calc_light_list(Obj, yes(Trans), BSList, Lights, NewObject).
-
-
-% If we get another kind of transform, spit the dummy....
-
-traverse_objects(_, _, transform(_, _), _) :-
- throw("traverse_objects can't handle complex transform objects!").
+ NewObject = difference(NewObject1, NewObject2)
+ ;
+ Obj = transform(SubObj, Trans),
+ % The only kind of transform we can handle
+ % is one wrapping a basic object.
+ ( SubObj = basic_object(_, _, _) ->
+ calc_light_list(SubObj, yes(Trans), BSList, Lights, NewObject)
+ ;
+ % If we get another kind of transform, spit the dummy....
+ throw("traverse_objects can't handle complex transform objects!")
+ )
+ ).
%------------------------------------------------------------------------------%
% calc_light_list adds the "clearly illuminating light" list to an object
-:- pred calc_light_list(
- object,
- maybe(transformation),
- list(bounding_sphere),
- list(light),
- object
-).
-:- mode calc_light_list(in(basic_object_inst), in, in, in, out) is det.
-
+:- pred calc_light_list(object::in(basic_object_inst),
+ maybe(transformation)::in, list(bounding_sphere)::in, list(light)::in,
+ object::out) is det.
% planes *might* go in here, if all objects are on the opposite side of them...
% but it's probably not worth the effort
calc_light_list(Obj, MaybeTrans, BSList, Lights, NewObject) :-
Obj = basic_object(Id, Obj2, LList0),
- (if (Obj2 = plane(_S)) then
+ ( if (Obj2 = plane(_S)) then
NewObject = Obj % for now, do nothing for planes
else
(
@@ -201,8 +210,8 @@
BBox = transform_bounding_box(BBox0,Trans2)
),
bsphere(Centre, Radius) = bounding_sphere(BBox),
- list__filter(is_clear(Centre, Radius, BSList), Lights, LList1),
- list__append(LList0, LList1, LList2),
+ list.filter(is_clear(Centre, Radius, BSList), Lights, LList1),
+ list.append(LList0, LList1, LList2),
NewObject = basic_object( Id, Obj2, LList2 )
).
@@ -211,12 +220,12 @@
% is_clear is true if none of the bounding spheres in BSList could cast a
% shadow on the object (Centre, Radius) against the light Light.
-:- pred is_clear(point, real, list(bounding_sphere), light).
-:- mode is_clear(in, in, in, in) is semidet.
+:- pred is_clear(point::in, real::in, list(bounding_sphere)::in, light::in)
+ is semidet.
is_clear(Centre, Radius, BSList, Light) :-
- list__filter(single_is_clear(Centre, Radius, Light), BSList, BadList),
- list__length(BadList, Len),
+ list.filter(single_is_clear(Centre, Radius, Light), BSList, BadList),
+ list.length(BadList, Len),
Len =< 1. % the only "non clear" bounding sphere is our own...
% single_is_clear is true if we can guarantee that one object does not
@@ -248,7 +257,6 @@
Light = directional(_, _),
Pos =scale(real_max / 2.0, light_unit_vector(Light,point(0.0,0.0,0.0))).
-
%------------------------------------------------------------------------------%
% bounding_sphere takes a pair of points and returns their "centre" and "radius"
Index: icfp2000_par/renderer.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/renderer.m,v
retrieving revision 1.1
diff -u -b -r1.1 renderer.m
--- icfp2000_par/renderer.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/renderer.m 10 Nov 2008 23:59:26 -0000
@@ -1,8 +1,20 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
:- module renderer.
:- interface.
-:- import_module eval, space_partition, trans, vector, tree.
-:- import_module list, io, pair, maybe.
+
+:- import_module eval.
+:- import_module space_partition.
+:- import_module trans.
+:- import_module tree.
+:- import_module vector.
+
+:- import_module io.
+:- import_module list.
+:- import_module maybe.
+:- import_module pair.
:- type render_params
---> render_params(
@@ -16,72 +28,100 @@
file :: string
).
-
-:- pred render(render_params::in, io::di, io::uo)
- is det.
+:- pred render(render_params::in, io::di, io::uo) is det.
:- type unimplemented_object
---> unimplemented_object(object).
% mea culpa - this is needed by precompute_lights.m
:- func light_unit_vector(light, position) = vector.
+
+:- pred set_target_parallelism(int::in, io::di, io::uo) is det.
+
+:- pred set_time_filename(string::in, io::di, io::uo) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module transform_object, gml, op.
+:- import_module gml.
+:- import_module op.
:- import_module precompute_lights.
-:- import_module map, array, exception, require, math.
-:- import_module int, float, list, maybe, pair, string.
+:- import_module transform_object.
-render(Params1) -->
- { Wid = Params1 ^ wid },
- { Ht = Params1 ^ ht },
- { FileName = Params1 ^ file },
- %
- % XXX Note that we first create an array,
- % and then output it. It would be slightly more
- % efficient to just output the values as we go along.
- %
- tell(FileName, Res),
- ( { Res = ok } ->
- output_stream(Stream),
- { private_builtin__unsafe_type_cast(Stream, BinStream) },
- set_binary_output_stream(BinStream, _Old),
- % Write the ppm header.
- format("P6\n", []),
- format("# Merry Mercuryians )O+\n", []),
- format("%d %d\n", [i(Wid), i(Ht)]),
- format("255\n", []),
+:- import_module array.
+:- import_module exception.
+:- import_module float.
+:- import_module int.
+:- import_module list.
+:- import_module map.
+:- import_module math.
+:- import_module maybe.
+:- import_module pair.
+:- import_module require.
+:- import_module string.
+
+render(Params1, !IO) :-
+ Wid = Params1 ^ wid,
+ Ht = Params1 ^ ht,
+ FileName = Params1 ^ file,
+
+ % XXX Note that we first create an array, and then output it.
+ % It would be slightly more efficient to just output the values
+ % as we go along.
+ io.tell(FileName, Result, !IO),
+ (
+ Result = ok,
+ output_stream(Stream, !IO),
+ private_builtin.unsafe_type_cast(Stream, BinStream),
+ set_binary_output_stream(BinStream, _Old, !IO),
+ % Write the ppm header.
+ io.format("P6\n", [], !IO),
+ io.format("# Merry Mercuryians )O+\n", [], !IO),
+ io.format("%d %d\n", [i(Wid), i(Ht)], !IO),
+ io.format("255\n", [], !IO),
% work in progress : pde
% Pre-compute lighting for "cleanly illuminated" objects
% first unfold the set of objects that might cast shadows
- %scene_list(Obj, ObjList),
+ % scene_list(Obj, ObjList),
% now use this to find object/light pairs which are clear of 'em
- %pre_compute_lighting(Obj, ObjList, Params1 ^ lights, NewScene),
- %Params2 = Params1 ^ scene := NewScene,
- { Params2 = Params1 },
+ % pre_compute_lighting(Obj, ObjList, Params1 ^ lights, NewScene),
+ % Params2 = Params1 ^ scene := NewScene,
+ Params2 = Params1,
+
+ % Render the image, and time the process.
+ gettimeofday(T0, !IO),
+ render_rows_par(Params2, Wid, Ht, !IO),
+ gettimeofday(T1, !IO),
+ io.told(!IO),
-
- % Render the image
- gettimeofday(T0),
- render_rows_par(Params2, 0, Wid, Ht),
- gettimeofday(T1),
-
- told,
-
- write_int(T1 - T0),
- nl
+ get_time_filename(TimeFileName, !IO),
+ ( TimeFileName = "" ->
+ true
+ ;
+ io.open_output(TimeFileName, TimeResult, !IO),
+ (
+ TimeResult = ok(TimeStream),
+ io.write_int(TimeStream, T1 - T0, !IO),
+ io.nl(TimeStream, !IO),
+ io.close_output(TimeStream, !IO)
+ ;
+ TimeResult = error(_),
+ throw(TimeResult)
+ )
+ )
;
- { throw(Res) }
+ Result = error(_),
+ throw(Result)
).
:- pred gettimeofday(int::out, io::di, io::uo) is det.
+
:- pragma foreign_proc("C",
gettimeofday(T::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, thread_safe],
@@ -92,10 +132,71 @@
IO = IO0;
").
-:- pred render_rows_par(render_params, int, int, int, io, io).
-:- mode render_rows_par(in, in, in, in, di, uo) is det.
+:- pragma foreign_decl("C",
+"
+ static int target_parallelism = 0;
+ static char *time_filename = (char *) """";
+").
+
+:- pragma foreign_proc("C",
+ set_target_parallelism(TargetParallelism::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ target_parallelism = TargetParallelism;
+ IO = IO0;
+").
-render_rows_par(Params, J, Width, Height, !IO) :-
+:- pred get_target_parallelism(int::out, io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ get_target_parallelism(TargetParallelism::out, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TargetParallelism = target_parallelism;
+ /* printf(""target parallelism %d\\n"", target_parallelism); */
+ IO = IO0;
+").
+
+:- pragma foreign_proc("C",
+ set_time_filename(TimeFileName::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ time_filename = TimeFileName;
+ IO = IO0;
+").
+
+:- pred get_time_filename(string::out, io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ get_time_filename(TimeFileName::out, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TimeFileName = time_filename;
+ /* printf(""time filename %s\\n"", time_filename); */
+ IO = IO0;
+").
+
+:- pred render_rows_par(render_params::in, int::in, int::in,
+ io::di, io::uo) is det.
+
+render_rows_par(Params, Width, Height, !IO) :-
+ get_target_parallelism(TargetParallelism, !IO),
+ ( TargetParallelism = 0 ->
+ render_rows(Params, 0, Width, Height, [], RevPixels),
+ write_rev_bytes(RevPixels, !IO)
+ ;
+ % Since Height / TargetParallelism may not be an integer, we need to
+ % decide which way to round it. The formula below rounds it up,
+ % since e.g. dividing 43 rows for 4 CPUs is better done as
+ % (11,11,11,10) than as (10,10,10,10,3).
+ BunchLines = (Height + TargetParallelism - 1) / TargetParallelism,
+ render_rows_par_2(Params, BunchLines, 0, Width, Height, !IO)
+ ).
+
+:- pred render_rows_par_2(render_params::in, int::in, int::in,
+ int::in, int::in, io::di, io::uo) is det.
+
+render_rows_par_2(Params, BunchLines, J, Width, Height, !IO) :-
( J >= Height ->
true
;
@@ -110,20 +211,21 @@
%
% If we set --max-contexts-per-thread to a large number (e.g. 500)
% and set --small-detstack-size to a small number,
- % then Lines = 1 works.
- %
- Lines = 1,
+ % then BunchLines = 1 works.
+
(
- render_rows(Params, J, Width, min(J+Lines, Height),
- [], RevPixels),
+ BunchHeight = int.min(J + BunchLines, Height),
+ % io.format("bunch: rows %d to %d\n", [i(J), i(BunchHeight)], !IO),
+ render_rows(Params, J, Width, BunchHeight, [], RevPixels),
write_rev_bytes(RevPixels, !IO)
&
- render_rows_par(Params, J+Lines, Width, Height, !IO)
+ render_rows_par_2(Params, BunchLines, J + BunchLines,
+ Width, Height, !IO)
)
).
-:- pred render_rows(render_params, int, int, int, list(int), list(int)).
-:- mode render_rows(in, in, in, in, in, out) is det.
+:- pred render_rows(render_params::in, int::in, int::in, int::in,
+ list(int)::in, list(int)::out) is det.
render_rows(Params, J, Width, JLimit, !RevPixels) :-
( J = JLimit ->
@@ -147,9 +249,8 @@
write_rev_bytes(Bs, !IO),
write_byte(B, !IO).
-:- pred render_pixel_loop(render_params, int, int, int,
- list(int), list(int)).
-:- mode render_pixel_loop(in, in, in, in, in, out) is det.
+:- pred render_pixel_loop(render_params::in, int::in, int::in, int::in,
+ list(int)::in, list(int)::out) is det.
render_pixel_loop(Params, I, J, Width, RevPixels0, RevPixels) :-
( I = Width ->
@@ -164,11 +265,9 @@
B = round_to_int(B0 * 255.0),
RevPixels1 = [B, G, R | RevPixels0],
- render_pixel_loop(Params, I + 1, J, Width,
- RevPixels1, RevPixels)
+ render_pixel_loop(Params, I + 1, J, Width, RevPixels1, RevPixels)
).
-%
% ALGORITHM OVERVIEW
%
% for each pixel in image
@@ -195,13 +294,16 @@
% Returns an object to ignore for intersections.
% Used to avoid surface acne.
:- func no_object = int.
+
no_object = 0.
% Finds the intensity from a ray.
:- pred fire_ray(render_params::in, object_id::in, point::in, vector::in,
color::out) is det.
+
fire_ray(RenderParams, IgnoreId, RayOrigin, RayDirection, Intensity) :-
- ( find_intersection(RenderParams, IgnoreId, RayOrigin, RayDirection,
+ (
+ find_intersection(RenderParams, IgnoreId, RayOrigin, RayDirection,
HitId, IntersectionPoint, UnitSurfaceNormal,
SurfaceCoords, SurfaceTextureFunc)
->
@@ -234,8 +336,9 @@
% origin to the intersection point.
:- type intersection_result == tree(pair(real, intersection)).
- % Combine two results into a tree, avoiding allocating
- % memory where possible.
+ % Combine two results into a tree, avoiding allocating memory
+ % where possible.
+ %
:- func make_tree(intersection_result, intersection_result)
= intersection_result.
@@ -274,18 +377,19 @@
%
% sanity_check_intersection(Position, Direction, Intersection0, Intersection) :-
% Int = Intersection0^intersection_point,
-% (
-% dot(Direction, Int - Position) > 0.0
-% ->
+% ( dot(Direction, Int - Position) > 0.0 ->
% Intersection = Intersection0
% ;
% throw(intersection_is_behind_vantage_point(Position,
% Direction, Intersection0))
% ).
%
-% :- type my_excp ---> intersection_is_behind_vantage_point(
-% position, vector, intersection).
-%
+% :- type my_excp
+% ---> intersection_is_behind_vantage_point(
+% position,
+% vector,
+% intersection
+% ).
:- pred find_scene_intersection(scene::in, point::in, vector::in,
intersection_result::out) is det.
@@ -309,6 +413,7 @@
% Choose the closest intersection in the intersection_result
% which is in front of the viewer.
+ %
:- pred choose_closest_intersection(position::in, vector::in,
intersection_result::in, object_id::in,
maybe(best_intersection)::out) is det.
@@ -334,8 +439,7 @@
:- type best_intersection == pair(real, intersection).
:- pred choose_maybe_intersection(maybe(best_intersection)::in,
- maybe(best_intersection)::in,
- maybe(best_intersection)::out) is det.
+ maybe(best_intersection)::in, maybe(best_intersection)::out) is det.
choose_maybe_intersection(no, no, no).
choose_maybe_intersection(yes(Best), no, yes(Best)).
@@ -374,23 +478,19 @@
RayOrigin, RayDirection, Intersection).
find_object_intersection(union(Object1, Object2), MaybeTransformation,
RayOrigin, RayDirection, Intersection) :-
- %
% find the points that intersect the surface of Object1
% and that are NOT inside Object2
- %
find_surface_and_not_object_intersection(Object1, Object2,
MaybeTransformation, RayOrigin, RayDirection,
Intersection1),
- %
+
% find the points that intersect the surface of Object2
% and that are NOT inside Object1
- %
find_surface_and_not_object_intersection(Object2, Object1,
MaybeTransformation, RayOrigin, RayDirection,
Intersection2),
- %
+
% Take the union of those.
- %
Intersection = make_tree(Intersection1, Intersection2).
/***********
@@ -404,52 +504,42 @@
find_object_intersection(intersect(Object1, Object2), MaybeTransformation,
RayOrigin, RayDirection, Intersection) :-
- %
% find the points that intersect the surface of Object1
% and that are inside Object2
- %
find_surface_and_object_intersection(Object1, Object2,
MaybeTransformation, RayOrigin, RayDirection,
Intersection1),
- %
+
% find the points that intersect the surface of Object2
% and that are inside Object1
- %
find_surface_and_object_intersection(Object2, Object1,
MaybeTransformation, RayOrigin, RayDirection,
Intersection2),
- %
+
% take the union of those
- %
Intersection = make_tree(Intersection1, Intersection2).
find_object_intersection(difference(Object1, Object2), MaybeTransformation,
RayOrigin, RayDirection, IntersectionResult) :-
- %
% find the points that intersect the surface of Object1
% and that are NOT inside Object2
- %
find_surface_and_not_object_intersection(Object1, Object2,
MaybeTransformation, RayOrigin, RayDirection,
Intersection1),
- %
+
% find the points that intersect the surface of Object2
% and that ARE inside Object1, and then reverse the
% normals of the intersection points
- %
find_surface_and_object_intersection(Object2, Object1,
- MaybeTransformation, RayOrigin, RayDirection,
- Intersection2),
+ MaybeTransformation, RayOrigin, RayDirection, Intersection2),
reverse_normals(Intersection2, Intersection3),
- %
+
% take the union of those
- %
IntersectionResult = tree(Intersection1, Intersection3).
-%
-% Find the points where a ray intersects the surface of one object
-% and is inside another object.
-%
+ % Find the points where a ray intersects the surface of one object
+ % and is inside another object.
+ %
:- pred find_surface_and_object_intersection(object::in, object::in,
maybe(transformation)::in, point::in, vector::in,
intersection_result::out) is det.
@@ -461,12 +551,11 @@
select_intersection_points_in_object(IntersectionResult0,
Object2, MaybeTransformation, IntersectionResult).
-%
-% Find the points where a ray intersects the surface of one object
-% and is NOT inside the other object.
-%
-% XXX should avoid code duplication
-
+ % Find the points where a ray intersects the surface of one object
+ % and is NOT inside the other object.
+ %
+ % XXX should avoid code duplication
+ %
:- pred find_surface_and_not_object_intersection(object::in, object::in,
maybe(transformation)::in, point::in, vector::in,
intersection_result::out) is det.
@@ -479,14 +568,14 @@
Object2, MaybeTransformation, IntersectionResult).
:- pred select_intersection_points_in_object(intersection_result::in,
- object::in, maybe(transformation)::in,
- intersection_result::out) is det.
+ object::in, maybe(transformation)::in, intersection_result::out) is det.
+
select_intersection_points_in_object(empty, _, _, empty).
select_intersection_points_in_object(node(I), Object,
MaybeTransformation, Tree) :-
I = _Dist - Intersection,
(
- point_is_in_object(Intersection^intersection_point,
+ point_is_in_object(Intersection ^ intersection_point,
Object, MaybeTransformation)
->
Tree = node(I)
@@ -498,11 +587,11 @@
select_intersection_points_in_object(I2, Object, MT, N2),
Tree = make_tree(N1, N2).
-% XXX should avoid code duplication
-
+ % XXX should avoid code duplication
+ %
:- pred select_intersection_points_NOT_in_object(intersection_result::in,
- object::in, maybe(transformation)::in,
- intersection_result::out) is det.
+ object::in, maybe(transformation)::in, intersection_result::out) is det.
+
select_intersection_points_NOT_in_object(empty, _, _, empty).
select_intersection_points_NOT_in_object(node(I), Object,
MaybeTransformation, Tree) :-
@@ -520,12 +609,13 @@
select_intersection_points_NOT_in_object(I2, Object, MT, N2),
Tree = make_tree(N1, N2).
-:- pred reverse_normals(intersection_result::in,
- intersection_result::out) is det.
+:- pred reverse_normals(intersection_result::in, intersection_result::out)
+ is det.
+
reverse_normals(empty, empty).
reverse_normals(node(Dist - Intersection0), node(Dist - Intersection)) :-
Intersection = Intersection0^surface_normal :=
- -(Intersection0^surface_normal).
+ - (Intersection0 ^ surface_normal).
reverse_normals(tree(I1, I2), make_tree(N1, N2)) :-
reverse_normals(I1, N1),
reverse_normals(I2, N2).
@@ -542,8 +632,8 @@
).
:- pred find_basic_object_intersection(object_id::in, basic_object::in,
- maybe(transformation)::in, point::in, vector::in,
- intersections::out) is det.
+ maybe(transformation)::in, point::in, vector::in, intersections::out)
+ is det.
find_basic_object_intersection(Id, Obj, MaybeTrans,
RayOrigin, RayDirection, Intersections) :-
@@ -552,32 +642,27 @@
RayOrigin, RayDirection, Intersections).
:- pred find_basic_object_intersection_2(object_id::in, basic_object::in,
- trans::in, point::in, vector::in,
- intersections::out) is det.
+ trans::in, point::in, vector::in, intersections::out) is det.
find_basic_object_intersection_2(Id, sphere(Surface), Trans, RayOrigin,
RayDirection, Intersections) :-
intersects_sphere(Id, Trans, RayOrigin, RayDirection,
Surface, Intersections).
-
find_basic_object_intersection_2(Id, Obj, Trans, RayOrigin, RayDirection,
Intersections) :-
Obj = plane(Surface),
intersects_plane(Id, Trans, RayOrigin, RayDirection,
Surface, Intersections).
-
find_basic_object_intersection_2(Id, Obj, Trans, RayOrigin, RayDirection,
Intersections) :-
Obj = cube(Surface),
intersects_cube(Id, Trans, RayOrigin, RayDirection,
Surface, Intersections).
-
find_basic_object_intersection_2(Id, Obj, Trans, RayOrigin, RayDirection,
Intersections) :-
Obj = cylinder(Surface),
intersects_cylinder(Id, Trans, RayOrigin, RayDirection,
Surface, Intersections).
-
find_basic_object_intersection_2(Id, Obj, Trans, RayOrigin, RayDirection,
Intersections) :-
Obj = cone(Surface),
@@ -591,21 +676,18 @@
% call the surface function to compute the object's texture at that point
%
-:- pred compute_texture(surface, surface_coordinates, surface_properties).
-:- mode compute_texture(in, in, out) is det.
+:- pred compute_texture(surface::in, surface_coordinates::in,
+ surface_properties::out) is det.
compute_texture(Surface, Coords, Properties) :-
Surface = surface(Env0, Code),
Coords = surface_coordinates(Face, U, V),
Stack0 = [real(V), real(U), int(Face)],
- interpret(Code, Env0, Stack0, _Env, Stack,
- global_object_counter(1), _),
+ interpret(Code, Env0, _Env, Stack0, Stack, global_object_counter(1), _),
( Stack = [real(N), real(Ks), real(Kd), point(C)] ->
Properties = surface_properties(C, Kd, Ks, N)
;
- throw(
- "surface texture function returned wrong number/type of values"
- )
+ throw("surface texture function returned wrong number/type of values")
).
compute_texture(Surface, _Coords, Properties) :-
Surface = constant(Properties).
@@ -619,12 +701,10 @@
:- pred compute_intensity(render_params::in, vector::in, object_id::in,
point::in, vector::in, surface_properties::in, color::out).
+
compute_intensity(RenderParams, RayDirection, IgnoreId, IntersectionPoint,
UnitSurfaceNormal, SurfaceProperties, I) :-
-
- %
% see equation (10) in the spec
- %
I0 = AmbientI + DirectionalOrPositionalI + ReflectedI,
I = clamp(I0),
@@ -650,7 +730,6 @@
ReflectedI = point(0.0, 0.0, 0.0)
),
-
% This is simple but could be done more
% efficiently.
%
@@ -670,14 +749,14 @@
Result1 = scale(DotProd, Ij * C)
)),
- array__to_list(Lights, LightList0),
+ array.to_list(Lights, LightList0),
- list__filter((pred(LightVal::in) is semidet :-
+ list.filter((pred(LightVal::in) is semidet :-
position_not_in_shadow(RenderParams, IgnoreId,
IntersectionPoint, LightVal)
), LightList0, LightList),
- ContributionList1 = list__map(LightContribution1, LightList),
+ ContributionList1 = list.map(LightContribution1, LightList),
% do we need unit?
LightContribution2 = (
@@ -685,14 +764,10 @@
% compute the direction to the light
Light = light_value_to_light(LightVal),
Lj = light_unit_vector(Light, IntersectionPoint),
- %
- % check that light is on the right side
- % of the surface
- %
+
+ % check that light is on the right side of the surface
SanityCheck = dot(UnitSurfaceNormal, Lj),
- (
- SanityCheck =< 0.0
- ->
+ ( SanityCheck =< 0.0 ->
Result = zero
;
Hj = unit(Lj - unit(RayDirection)),
@@ -700,19 +775,17 @@
( ReflectionBase =< 0.0 ->
Result = zero
;
- Ij = light_intensity(Light,
- IntersectionPoint),
- Result = scale(math__pow(ReflectionBase,
- PhongExp), Ij * C)
+ Ij = light_intensity(Light, IntersectionPoint),
+ Result = scale(math.pow(ReflectionBase, PhongExp), Ij * C)
)
)
),
- ContributionList2 = list__map(LightContribution2, LightList),
+ ContributionList2 = list.map(LightContribution2, LightList),
- SumContributions1 = list__foldl(+, ContributionList1,
+ SumContributions1 = list.foldl(+, ContributionList1,
point(0.0, 0.0, 0.0)),
- SumContributions2 = list__foldl(+, ContributionList2,
+ SumContributions2 = list.foldl(+, ContributionList2,
point(0.0, 0.0, 0.0)),
DirectionalOrPositionalI = scale(Kd, SumContributions1) +
@@ -720,8 +793,9 @@
% Filter out all lights which are blocked by some
% object, not including the object on whose surface Position is.
-:- pred position_not_in_shadow(render_params, object_id, position, value).
-:- mode position_not_in_shadow(in, in, in, in) is semidet.
+ %
+:- pred position_not_in_shadow(render_params::in, object_id::in, position::in,
+ value::in) is semidet.
position_not_in_shadow(RenderParams, IgnoreId, Position, LightVal) :-
Light = light_value_to_light(LightVal),
@@ -734,8 +808,9 @@
% light_is_behind_point(VantagePoint, Light, Intersection) is true
% if Intersection is in between the Light and the Vantage.
-:- pred light_is_behind_point(position, light, position).
-:- mode light_is_behind_point(in, in, in) is semidet.
+ %
+:- pred light_is_behind_point(position::in, light::in, position::in)
+ is semidet.
light_is_behind_point(Vantage, directional(Dir, _), Point) :-
% Ensure that the Point is in the same direction as the light
@@ -749,6 +824,7 @@
dot(LightPos - Point, Vantage - Point) < 0.0.
:- func light_value_to_light(value) = light.
+
light_value_to_light(Val) = Light :-
( Val = light(Light0) ->
Light = Light0
@@ -757,7 +833,9 @@
).
% Return the intensity of this light at the given position.
+ %
:- func light_intensity(light, position) = color.
+
light_intensity(directional(_Dir, Intensity), _Point) = Intensity.
light_intensity(pointlight(Pos, Intensity), Point) =
scale(distance_attenuation(Pos, Point), Intensity).
@@ -766,21 +844,20 @@
DistanceAttenuation = distance_attenuation(Pos, Point),
AngleCos = dot(unit(At - Pos), unit(Point - Pos)),
- (
- AngleCos > math__cos(radians(Cutoff))
- ->
- AngleAttenuation = math__pow(AngleCos, Exp)
+ ( AngleCos > math.cos(radians(Cutoff)) ->
+ AngleAttenuation = math.pow(AngleCos, Exp)
;
AngleAttenuation = 0.0
).
:- func distance_attenuation(position, position) = real.
+
distance_attenuation(Pos1, Pos2) = 100.0 / (99.0 + D2) :-
D2 = mag2(Pos2 - Pos1).
% Return Lj -- the direction to the light source.
- % For directional lights, the unit vector is essentially
- % constant.
+ % For directional lights, the unit vector is essentially constant.
+ %
light_unit_vector(directional(Dir, _Intensity), _Point) = unit(-Dir).
light_unit_vector(pointlight(Pos, _Intensity), Point) = unit(Pos - Point).
light_unit_vector(spotlight(Pos, _At, _Intensity, _Cutoff, _Exp), Point) =
@@ -835,7 +912,9 @@
Direction = pixel_direction_2(Fov, WidthInPixels, HeightInPixels, I, J).
% return the direction of the Jth pixel in the Ith row
+ %
:- func pixel_direction_2(real, int, int, int, int) = vector.
+
pixel_direction_2(Fov, WidthInPixels, HeightInPixels, I, J) = Direction :-
TopLeft = image_topleft(Fov, WidthInPixels, HeightInPixels),
TopLeft = point(TopLeftX, TopLeftY, _),
@@ -848,10 +927,11 @@
:- pred point_is_in_object(point::in, object::in, maybe(transformation)::in)
is semidet.
-point_is_in_object(Point, basic_object(_Id, Obj, _List), MaybeTransformation) :-
+point_is_in_object(Point, basic_object(_Id, Obj, _List),
+ MaybeTransformation) :-
point_is_in_basic_object(Point, Obj, MaybeTransformation).
-point_is_in_object(Point, transform(Obj, Transformation1), MaybeTransformation)
- :-
+point_is_in_object(Point, transform(Obj, Transformation1),
+ MaybeTransformation) :-
( MaybeTransformation = yes(_) ->
% All transformations should have been collapsed into
% a single transformation.
@@ -886,8 +966,7 @@
Trans = Trans1
;
% All transformations should now be matrices
- % because push_transformations was applied to
- % the object.
+ % because push_transformations was applied to the object.
throw(invalid_transformation(Trans0))
)
;
@@ -916,7 +995,6 @@
intersection_list_to_tree(RayOrigin, [Int | Ints]) =
tree(node(DistanceSquared - Int), Tree0) :-
Tree0 = intersection_list_to_tree(RayOrigin, Ints),
- DistanceSquared =
- distance_squared(RayOrigin, Int ^ intersection_point).
+ DistanceSquared = distance_squared(RayOrigin, Int ^ intersection_point).
%-----------------------------------------------------------------------------%
Index: icfp2000_par/space_partition.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/space_partition.m,v
retrieving revision 1.1
diff -u -b -r1.1 space_partition.m
--- icfp2000_par/space_partition.m 10 Nov 2008 03:58:07 -0000 1.1
+++ icfp2000_par/space_partition.m 10 Nov 2008 07:53:46 -0000
@@ -1,9 +1,18 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
:- module space_partition.
:- interface.
-:- import_module list, pair.
-:- import_module vector, eval, renderer, trans.
+:- import_module eval.
+:- import_module renderer.
+:- import_module trans.
+:- import_module vector.
+
+:- import_module list.
+:- import_module pair.
:- func create_scene(object) = scene.
@@ -31,16 +40,13 @@
list(space_tree_node)
).
-
:- type space_tree_node
---> node(
space_tree
)
- ;
- leaf(
+ ; leaf(
space_tree_object
- )
- .
+ ).
:- type space_tree_object
---> space_tree_object(
@@ -49,7 +55,6 @@
object
).
-
:- pred traverse_space_tree(space_tree::in, point::in, vector::in,
intersection_result::out) is det.
@@ -57,16 +62,23 @@
:- func find_object_bounding_box(object) = bounding_box.
:- func transform_bounding_box(bounding_box, trans) = bounding_box.
+%---------------------------------------------------------------------------%
+
:- implementation.
:- import_module tree.
-:- import_module bool, exception, int, float, math, maybe.
+
+:- import_module bool.
+:- import_module exception.
+:- import_module float.
+:- import_module int.
+:- import_module math.
+:- import_module maybe.
create_scene(Obj) = scene(Tree, Others) :-
split_partitionable_objects(Obj, Partitionable, Others),
Tree = build_space_tree(Partitionable).
-
:- pred split_partitionable_objects(object::in, list(object)::out,
list(object)::out) is det.
@@ -76,15 +88,15 @@
Partitionable1, NonPartitionable1),
split_partitionable_objects(Object2,
Partitionable2, NonPartitionable2),
- list__append(Partitionable1, Partitionable2, Partitionable),
- list__append(NonPartitionable1, NonPartitionable2, NonPartitionable).
+ list.append(Partitionable1, Partitionable2, Partitionable),
+ list.append(NonPartitionable1, NonPartitionable2, NonPartitionable).
split_partitionable_objects(transform(Object, Trans),
Partitionable, NonPartitionable) :-
split_partitionable_objects(Object, Partitionable0, NonPartitionable0),
TransformObject = (func(Object1) = transform(Object1, Trans)),
- Partitionable = list__map(TransformObject, Partitionable0),
- NonPartitionable = list__map(TransformObject, NonPartitionable0).
+ Partitionable = list.map(TransformObject, Partitionable0),
+ NonPartitionable = list.map(TransformObject, NonPartitionable0).
split_partitionable_objects(basic_object(Id, Obj, Light),
Partitionable, NonPartitionable) :-
@@ -131,14 +143,11 @@
object_contains_plane(transform(Obj, _)) =
object_contains_plane(Obj).
object_contains_plane(union(Obj1, Obj2)) = Result :-
- bool__and(object_contains_plane(Obj1), object_contains_plane(Obj2),
- Result).
+ bool.and(object_contains_plane(Obj1), object_contains_plane(Obj2), Result).
object_contains_plane(intersect(Obj1, Obj2)) = Result :-
- bool__and(object_contains_plane(Obj1), object_contains_plane(Obj2),
- Result).
+ bool.and(object_contains_plane(Obj1), object_contains_plane(Obj2), Result).
object_contains_plane(difference(Obj1, Obj2)) = Result :-
- bool__and(object_contains_plane(Obj1), object_contains_plane(Obj2),
- Result).
+ bool.and(object_contains_plane(Obj1), object_contains_plane(Obj2), Result).
%-----------------------------------------------------------------------------%
@@ -197,7 +206,6 @@
throw(invalid_object(basic_object(0, plane(Obj), []))).
transform_bounding_box(Point1 - Point2, Trans) = MinPoint - MaxPoint :-
-
Point1 = point(X1, Y1, Z1),
Point2 = point(X2, Y2, Z2),
Point3 = point(X2, Y1, Z1),
@@ -242,15 +250,15 @@
:- func build_space_tree(list(object)) = space_tree.
build_space_tree(Objects) = Tree :-
- Max = float__max,
- Min = float__min,
+ Max = float.max,
+ Min = float.min,
MinBound = point(Max, Max, Max),
MaxBound = point(Min, Min, Min),
BoundingBox = MinBound - MaxBound,
SurfaceArea = 0.0,
Tree0 = space_tree(BoundingBox, SurfaceArea, []),
- SpaceObjects = list__map(
+ SpaceObjects = list.map(
(func(Object) = space_tree_object(BBox, ObjSurfaceArea, Object) :-
BBox = find_object_bounding_box(Object),
ObjSurfaceArea = bounding_box_surface_area(BBox)
@@ -259,60 +267,55 @@
% We might want to shuffle the input objects to
% avoid pathological inputs from the modeller.
- list__foldl(space_tree_insert, SpaceObjects, Tree0, Tree).
+ list.foldl(space_tree_insert, SpaceObjects, Tree0, Tree).
/*
-:- pred write_space_tree(space_tree::in, io__state::di, io__state::uo) is det.
+:- pred write_space_tree(space_tree::in, io::di, io::uo) is det.
write_space_tree(space_tree(Box, Area, Nodes)) -->
- io__write_string("tree(\n"),
- io__write_string("bounding box: "),
- io__write(Box),
- io__nl,
- io__write_string("area: "),
- io__write_float(Area),
- io__nl,
- io__write_string("["),
- io__write_list(Nodes, "\n", write_space_node),
- io__write_string("]\n").
+ io.write_string("tree(\n"),
+ io.write_string("bounding box: "),
+ io.write(Box),
+ io.nl,
+ io.write_string("area: "),
+ io.write_float(Area),
+ io.nl,
+ io.write_string("["),
+ io.write_list(Nodes, "\n", write_space_node),
+ io.write_string("]\n").
-:- pred write_space_node(space_tree_node::in,
- io__state::di, io__state::uo) is det.
+:- pred write_space_node(space_tree_node::in, io::di, io::uo) is det.
write_space_node(node(Tree)) -->
- io__write_string("sub-tree:\n"),
+ io.write_string("sub-tree:\n"),
write_space_tree(Tree),
- io__nl.
+ io.nl.
write_space_node(leaf(Leaf)) -->
- io__write_string("leaf:\n"),
- io__write(Leaf),
- io__nl.
+ io.write_string("leaf:\n"),
+ io.write(Leaf),
+ io.nl.
*/
:- pred space_tree_insert(space_tree_object::in,
space_tree::in, space_tree::out) is det.
-space_tree_insert(Object, space_tree(OldBox, _, Subtrees0),
- Tree) :-
+space_tree_insert(Object, space_tree(OldBox, _, Subtrees0), Tree) :-
Object = space_tree_object(ObjBox, _, _),
NewBox = max_box(OldBox, ObjBox),
NewSurfaceArea = bounding_box_surface_area(NewBox),
(
- Subtrees0 = []
- ->
+ Subtrees0 = [],
Subtrees = [leaf(Object)]
;
- Subtrees0 = [Leaf]
- ->
+ Subtrees0 = [Leaf],
Subtrees = [leaf(Object), Leaf]
;
+ Subtrees0 = [_, _ | _],
SurfaceAreaChange = real_max,
select_subtree(ObjBox, Subtrees0, 1,
- SurfaceAreaChange - 0,
- SelectedSubtree),
+ SurfaceAreaChange - 0, SelectedSubtree),
subtree_insert(Subtrees0, SelectedSubtree, Object, Subtrees)
-
),
Tree = space_tree(NewBox, NewSurfaceArea, Subtrees).
@@ -324,8 +327,7 @@
).
:- pred select_subtree(bounding_box::in, list(space_tree_node)::in,
- int::in, pair(surface_area, int)::in,
- int::out) is det.
+ int::in, pair(surface_area, int)::in, int::out) is det.
select_subtree(_, [], _, _ - Selected, Selected).
select_subtree(ObjBox, [Subtree | Subtrees], Index,
@@ -372,6 +374,7 @@
).
% Compute the surface area of the bounding box.
+ %
:- func bounding_box_surface_area(bounding_box) = float.
bounding_box_surface_area(point(X1, Y1, Z1) - point(X2, Y2, Z2)) =
@@ -448,7 +451,6 @@
double dir[3], double coord[3]);
").
-
:- pragma c_code("
Bool HitBoundingBox(double minB[3],double maxB[3], double origin[3],
double dir[3], double coord[3])
@@ -462,61 +464,68 @@
/* Find candidate planes; this loop can be avoided if
rays cast all from the eye(assume perpsective view) */
- for (i=0; i<NUMDIM; i++)
- if(origin[i] < minB[i]) {
+ for (i = 0; i<NUMDIM; i++)
+ if (origin[i] < minB[i]) {
quadrant[i] = LEFT;
candidatePlane[i] = minB[i];
inside = MR_FALSE;
- }else if (origin[i] > maxB[i]) {
+ } else if (origin[i] > maxB[i]) {
quadrant[i] = RIGHT;
candidatePlane[i] = maxB[i];
inside = MR_FALSE;
- }else {
+ } else {
quadrant[i] = MIDDLE;
}
/* Ray origin inside bounding box */
- if(inside) {
+ if (inside) {
coord = origin;
return (MR_TRUE);
}
-
/* Calculate T distances to candidate planes */
- for (i = 0; i < NUMDIM; i++)
- if (quadrant[i] != MIDDLE && dir[i] !=0.)
+ for (i = 0; i < NUMDIM; i++) {
+ if (quadrant[i] != MIDDLE && dir[i] !=0.) {
maxT[i] = (candidatePlane[i]-origin[i]) / dir[i];
- else
+ } else {
maxT[i] = -1.;
+ }
+ }
/* Get largest of the maxT's for final choice of intersection */
whichPlane = 0;
- for (i = 1; i < NUMDIM; i++)
- if (maxT[whichPlane] < maxT[i])
+ for (i = 1; i < NUMDIM; i++) {
+ if (maxT[whichPlane] < maxT[i]) {
whichPlane = i;
+ }
+ }
/* Check final candidate actually inside box */
if (maxT[whichPlane] < 0.) {
return (MR_FALSE);
}
- for (i = 0; i < NUMDIM; i++)
+
+ for (i = 0; i < NUMDIM; i++) {
if (whichPlane != i) {
coord[i] = origin[i] + maxT[whichPlane] *dir[i];
- if (coord[i] < minB[i] || coord[i] > maxB[i])
+ if (coord[i] < minB[i] || coord[i] > maxB[i]) {
return (MR_FALSE);
+ }
} else {
coord[i] = candidatePlane[i];
}
+ }
+
return (MR_TRUE); /* ray hits box */
}").
:- pred traverse_space_tree_nodes(list(space_tree_node)::in,
- point::in, vector::in, intersection_result::in,
- intersection_result::out) is det.
+ point::in, vector::in, intersection_result::in, intersection_result::out)
+ is det.
traverse_space_tree_nodes([], _, _, Results, Results).
-traverse_space_tree_nodes([Node | Nodes], RayOrigin,
- RayDirection, Results0, Results) :-
+traverse_space_tree_nodes([Node | Nodes], RayOrigin, RayDirection,
+ Results0, Results) :-
(
Node = leaf(SpaceObject),
SpaceObject = space_tree_object(_, _, Object),
@@ -549,11 +558,9 @@
partition,
partition
)
- ;
- objects(
+ ; objects(
list(object)
- )
- .
+ ).
:- func max_partition_depth = int.
@@ -571,7 +578,7 @@
LeftBoundingBox, RightBoundingBox),
partition_objects_2(Midpoint, Normal, Objects,
LeftPartition, RightPartition, NumInBoth),
- NumObjects = list__length(Objects),
+ NumObjects = list.length(Objects),
( NumInBoth * 2 > NumObjects ->
Partition = objects(Objects)
;
@@ -628,8 +635,7 @@
partition_objects_2(_Point, _Normal, [], [], [], 0).
partition_objects_2(Point, Normal, [Obj|Objs], LeftObjs, RightObjs, InBoth) :-
WhichSide = which_side(Obj, Point, Normal),
- partition_objects_2(Point, Normal, Objs,
- LeftObjs0, RightObjs0, InBoth0),
+ partition_objects_2(Point, Normal, Objs, LeftObjs0, RightObjs0, InBoth0),
(
WhichSide = left,
LeftObjs = [Obj|LeftObjs0],
@@ -647,12 +653,10 @@
InBoth = InBoth0 + 1
).
-
:- type side
---> left
; right
- ; both
- .
+ ; both.
:- func which_side(object, point, normal) = side.
@@ -757,12 +761,10 @@
(
PartitionToTraverse = left,
- traverse_partition(LeftPartition, RayOrigin,
- RayDirection, Result)
+ traverse_partition(LeftPartition, RayOrigin, RayDirection, Result)
;
PartitionToTraverse = right,
- traverse_partition(RightPartition, RayOrigin,
- RayDirection, Result)
+ traverse_partition(RightPartition, RayOrigin, RayDirection, Result)
;
PartitionToTraverse = both,
traverse_partition(LeftPartition, RayOrigin,
Index: icfp2000_par/test_trans.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/test_trans.m,v
retrieving revision 1.1
diff -u -b -r1.1 test_trans.m
--- icfp2000_par/test_trans.m 10 Nov 2008 03:58:08 -0000 1.1
+++ icfp2000_par/test_trans.m 10 Nov 2008 07:43:36 -0000
@@ -1,16 +1,25 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
:- module test_trans.
:- interface.
:- import_module io.
-:- pred main(io__state::di, io__state::uo) is det.
+:- pred main(io::di, io::uo) is det.
% ---------------------------------------------------------------------------- %
:- implementation.
-:- import_module vector, trans, string, list, float.
-main -->
+:- import_module trans.
+:- import_module vector.
+
+:- import_module float.
+:- import_module list.
+:- import_module string.
+main -->
test_trans("translation by 10 20 30", compose_translate(10.0, 20.0, 30.0)),
test_trans("scaling by 2 4 8", compose_scale(2.0, 4.0, 8.0)),
test_trans("scaling by 2", compose_uscale(2.0)),
@@ -75,9 +84,8 @@
% ---------------------------------------------------------------------------- %
-:- pred test_trans(string, func(trans) = trans,
- io__state, io__state).
-:- mode test_trans(in, func(in) = out is det, di, uo) is det.
+:- pred test_trans(string::in, (func(trans) = trans)::in,
+ io::di, io::uo) is det.
test_trans(Name, Trans) -->
{ X0 = point(1.0, 0.0, 0.0) },
@@ -90,7 +98,7 @@
{ Z1 = point_to_object_space(T, Z0), Z2 = point_to_world_space(T, Z1) },
{ R1 = point_to_object_space(T, R0), R2 = point_to_world_space(T, R1) },
- io__format("\n\nTest %s:\n", [s(Name)]),
+ io.format("\n\nTest %s:\n", [s(Name)]),
print("\ntransformation:\n"), show_trans(T),
@@ -112,84 +120,107 @@
% ---------------------------------------------------------------------------- %
-:- pred test_plane(float, float, float, float, float, float,
- io__state, io__state).
-:- mode test_plane(in, in, in, in, in, in, di, uo) is det.
-
-test_plane(X, Y, Z, Dx, Dy, Dz) -->
- { P = point(X, Y, Z) },
- { D = point(Dx, Dy, Dz) },
- print("\n\nThe line "), show_point(P), print(" + t"), show_point(D), nl,
- ( if { intersects_plane(identity, P, D, POI, _TC, _N) } then
- print("intersects the plane y = 0 at "), show_point(POI), nl
+:- pred test_plane(float::in, float::in, float::in, float::in, float::in,
+ float::in, io::di, io::uo) is det.
+
+test_plane(X, Y, Z, Dx, Dy, Dz, !IO) :-
+ P = point(X, Y, Z),
+ D = point(Dx, Dy, Dz),
+ io.print("\n\nThe line ", !IO),
+ show_point(P, !IO),
+ io.print(" + t", !IO),
+ show_point(D, !IO),
+ io.nl(!IO),
+ ( if intersects_plane(identity, P, D, POI, _TC, _N) then
+ io.print("intersects the plane y = 0 at ", !IO),
+ show_point(POI, !IO),
+ io.nl(!IO)
else
- print("DOES NOT intersect the plane y = 0\n")
+ io.print("DOES NOT intersect the plane y = 0\n", !IO)
).
% ---------------------------------------------------------------------------- %
-:- pred test_sphere(float, float, float, float, float, float,
- io__state, io__state).
-:- mode test_sphere(in, in, in, in, in, in, di, uo) is det.
-
-test_sphere(X, Y, Z, Dx, Dy, Dz) -->
- { P = point(X, Y, Z) },
- { D = point(Dx, Dy, Dz) },
- print("\n\nThe line "), show_point(P), print(" + t"), show_point(D), nl,
- ( if { intersects_sphere(identity, P, D, POI, TC, _N) } then
- print("intersects the unit origin sphere at "), show_point(POI),
- { TC = surface_coordinates(S, U, V) },
- print("\n\t(face u v) = "), show_point(point(float(S), U, V)), nl
+:- pred test_sphere(float::in, float::in, float::in, float::in, float::in,
+ float::in, io::di, io::uo) is det.
+
+test_sphere(X, Y, Z, Dx, Dy, Dz, !IO) :-
+ P = point(X, Y, Z),
+ D = point(Dx, Dy, Dz),
+ io.print("\n\nThe line ", !IO),
+ show_point(P, !IO),
+ io.print(" + t", !IO),
+ show_point(D, !IO),
+ io.nl(!IO),
+ ( if intersects_sphere(identity, P, D, POI, TC, _N) then
+ io.print("intersects the unit origin sphere at ", !IO),
+ show_point(POI, !IO),
+ TC = surface_coordinates(S, U, V),
+ io.print("\n\t(face u v) = ", !IO),
+ show_point(point(float(S), U, V), !IO),
+ io.nl(!IO)
else
- print("DOES NOT intersect the unit origin sphere\n")
+ io.print("DOES NOT intersect the unit origin sphere\n", !IO)
).
% ---------------------------------------------------------------------------- %
-:- pred test_cube(float, float, float, float, float, float,
- io__state, io__state).
-:- mode test_cube(in, in, in, in, in, in, di, uo) is det.
-
-test_cube(X, Y, Z, Dx, Dy, Dz) -->
- { P = point(X, Y, Z) },
- { D = point(Dx, Dy, Dz) },
- print("\n\nThe line "), show_point(P), print(" + t"), show_point(D), nl,
- ( if { intersects_cube(identity, P, D, POI, TC, N) } then
- print("intersects the unit origin cube at "), show_point(POI),
- { TC = surface_coordinates(S, U, V) },
- print("\n\t(face u v) = "), show_point(point(float(S), U, V)),
- print("\n\tnormal = "), show_point(N), nl
+:- pred test_cube(float::in, float::in, float::in, float::in, float::in,
+ float::in, io::di, io::uo) is det.
+
+test_cube(X, Y, Z, Dx, Dy, Dz, !IO) :-
+ P = point(X, Y, Z),
+ D = point(Dx, Dy, Dz),
+ io.print("\n\nThe line ", !IO),
+ show_point(P, !IO),
+ io.print(" + t", !IO),
+ show_point(D, !IO),
+ io.nl(!IO),
+ ( if intersects_cube(identity, P, D, POI, TC, N) then
+ io.print("intersects the unit origin cube at ", !IO),
+ show_point(POI, !IO),
+ TC = surface_coordinates(S, U, V),
+ io.print("\n\t(face u v) = ", !IO),
+ show_point(point(float(S), U, V), !IO),
+ io.print("\n\tnormal = ", !IO),
+ show_point(N, !IO),
+ io.nl(!IO)
else
- print("DOES NOT intersect the unit origin cube\n")
+ io.print("DOES NOT intersect the unit origin cube\n", !IO)
).
% ---------------------------------------------------------------------------- %
-:- pred test_cylinder(float, float, float, float, float, float,
- io__state, io__state).
-:- mode test_cylinder(in, in, in, in, in, in, di, uo) is det.
-
-test_cylinder(X, Y, Z, Dx, Dy, Dz) -->
- { P = point(X, Y, Z) },
- { D = point(Dx, Dy, Dz) },
- print("\n\nThe line "), show_point(P), print(" + t"), show_point(D), nl,
- ( if { intersects_cylinder(identity, P, D, POI, TC, N) } then
- print("intersects the unit origin cylinder at "), show_point(POI),
- { TC = surface_coordinates(S, U, V) },
- print("\n\t(face u v) = "), show_point(point(float(S), U, V)),
- print("\n\tnormal = "), show_point(N), nl
+:- pred test_cylinder(float::in, float::in, float::in, float::in, float::in,
+ float::in, io::di, io::uo) is det.
+
+test_cylinder(X, Y, Z, Dx, Dy, Dz, !IO) :-
+ P = point(X, Y, Z),
+ D = point(Dx, Dy, Dz),
+ io.print("\n\nThe line ", !IO),
+ show_point(P, !IO),
+ io.print(" + t", !IO),
+ show_point(D, !IO),
+ io.nl(!IO),
+ ( if intersects_cylinder(identity, P, D, POI, TC, N) then
+ io.print("intersects the unit origin cylinder at ", !IO),
+ show_point(POI, !IO),
+ TC = surface_coordinates(S, U, V),
+ io.print("\n\t(face u v) = ", !IO),
+ show_point(point(float(S), U, V), !IO),
+ io.print("\n\tnormal = ", !IO),
+ show_point(N, !IO),
+ io.nl(!IO)
else
- print("DOES NOT intersect the unit origin cylinder\n")
+ io.print("DOES NOT intersect the unit origin cylinder\n", !IO)
).
% ---------------------------------------------------------------------------- %
-:- pred show_point(point, io__state, io__state).
-:- mode show_point(in, di, uo) is det.
+:- pred show_point(point::in, io::di, io::uo) is det.
-show_point(point(X, Y, Z)) -->
- io__format("(%4.1f %4.1f %4.1f)", [f(X), f(Y), f(Z)]).
+show_point(point(X, Y, Z), !IO) :-
+ io.format("(%4.1f %4.1f %4.1f)", [f(X), f(Y), f(Z)], !IO).
% ---------------------------------------------------------------------------- %
% ---------------------------------------------------------------------------- %
-
Index: icfp2000_par/trans.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/trans.m,v
retrieving revision 1.1
diff -u -b -r1.1 trans.m
--- icfp2000_par/trans.m 10 Nov 2008 03:58:08 -0000 1.1
+++ icfp2000_par/trans.m 10 Nov 2008 07:29:06 -0000
@@ -1,8 +1,11 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
% ---------------------------------------------------------------------------- %
% trans.m
% Ralph Becket <rbeck at microsoft.com>
% Sun Aug 27 11:22:32 2000
-% vim: ts=4 sw=4 et tw=0 wm=0 ff=unix
%
% This module computes the composition of the various transformations
% and their inverses. Also handles intersection between lines and
@@ -52,10 +55,12 @@
:- interface.
-:- import_module float, io, list.
-:- import_module vector, eval.
-
+:- import_module eval.
+:- import_module vector.
+:- import_module float.
+:- import_module io.
+:- import_module list.
:- type surface_coordinates
---> surface_coordinates(
@@ -64,15 +69,11 @@
surface_v :: real
).
-
-
% The type of transformation matrices (contains both the
% forward transformation M and its inverse W).
%
:- type trans.
-
-
% Apply a transformation matrix to points, vectors and normals.
%
% NOTE: when transforming a normal, one has to use
@@ -92,8 +93,6 @@
:- func vector_to_world_space(trans, point) = point.
:- func normal_to_world_space(trans, point) = point.
-
-
% The identity transformation (i.e. the unit matrix - start here!)
%
:- func identity = trans.
@@ -126,7 +125,6 @@
%
:- func compose_rotatez(float, trans) = trans.
-
:- type intersection
---> intersection(
object_id :: object_id,
@@ -148,57 +146,43 @@
% intersects_shape(Id, M, W, P, D, POI, TC, N).
% intersects_shape(MandW, P, D, POI, TC, N).
%
-:- pred intersects_plane(object_id, trans, point, vector, surface,
- intersections).
-:- mode intersects_plane(in, in, in, in, in, out) is det.
-
-:- pred intersects_sphere(object_id, trans, point, vector, surface,
- intersections).
-:- mode intersects_sphere(in, in, in, in, in, out) is det.
-
-:- pred intersects_cube(object_id, trans, point, vector, surface,
- intersections).
-:- mode intersects_cube(in, in, in, in, in, out) is det.
-
-:- pred intersects_cylinder(object_id, trans, point, vector, surface,
- intersections).
-:- mode intersects_cylinder(in, in, in, in, in, out) is det.
-
-:- pred intersects_cone(object_id, trans, point, vector, surface,
- intersections).
-:- mode intersects_cone(in, in, in, in, in, out) is det.
-
-
- % Decide whether we're inside a given object.
- %
-:- pred inside_sphere(point, trans).
-:- mode inside_sphere(in, in) is semidet.
+:- pred intersects_plane(object_id::in, trans::in, point::in, vector::in,
+ surface::in, intersections::out) is det.
-:- pred inside_plane(point, trans).
-:- mode inside_plane(in, in) is semidet.
+:- pred intersects_sphere(object_id::in, trans::in, point::in, vector::in,
+ surface::in, intersections::out) is det.
-:- pred inside_cube(point, trans).
-:- mode inside_cube(in, in) is semidet.
+:- pred intersects_cube(object_id::in, trans::in, point::in, vector::in,
+ surface::in, intersections::out) is det.
-:- pred inside_cylinder(point, trans).
-:- mode inside_cylinder(in, in) is semidet.
-
-:- pred inside_cone(point, trans).
-:- mode inside_cone(in, in) is semidet.
+:- pred intersects_cylinder(object_id::in, trans::in, point::in, vector::in,
+ surface::in, intersections::out) is det.
+:- pred intersects_cone(object_id::in, trans::in, point::in, vector::in,
+ surface::in, intersections::out) is det.
+ % Decide whether we're inside a given object.
+ %
+:- pred inside_sphere(point::in, trans::in) is semidet.
+:- pred inside_plane(point::in, trans::in) is semidet.
+:- pred inside_cube(point::in, trans::in) is semidet.
+:- pred inside_cylinder(point::in, trans::in) is semidet.
+:- pred inside_cone(point::in, trans::in) is semidet.
% Print out a transformation.
%
-:- pred show_trans(trans, io__state, io__state).
-:- mode show_trans(in, di, uo) is det.
+:- pred show_trans(trans::in, io::di, io::uo) is det.
% ---------------------------------------------------------------------------- %
% ---------------------------------------------------------------------------- %
:- implementation.
-:- import_module exception, string, math, list, std_util.
+:- import_module exception.
+:- import_module list.
+:- import_module math.
+:- import_module std_util.
+:- import_module string.
% NOTE 1: points and vectors are represented using the point/3 type
% defined in eval.m. For the purposes, a point (x, y, z) is
@@ -227,8 +211,6 @@
% 0, 0, 0, 1
).
-
-
:- func unit_matrix = matrix.
:- func transform_point(matrix, point) = point.
@@ -240,7 +222,6 @@
% ---------------------------------------------------------------------------- %
transform_point(M, P0) = P :-
-
M = matrix(M11, M12, M13, M14,
M21, M22, M23, M24,
M31, M32, M33, M34),
@@ -254,7 +235,6 @@
% ---------------------------------------------------------------------------- %
transform_vector(M, V0) = V :-
-
M = matrix(M11, M12, M13, _M14,
M21, M22, M23, _M24,
M31, M32, M33, _M34),
@@ -270,7 +250,6 @@
% Here, we multiply by the transpose of the matrix.
%
transform_normal(M, N0) = N :-
-
M = matrix(M11, M12, M13, _M14,
M21, M22, M23, _M24,
M31, M32, M33, _M34),
@@ -307,7 +286,6 @@
% ---------------------------------------------------------------------------- %
compose_translate(Dx, Dy, Dz, trans(M0, W0)) = trans(M, W) :-
-
M0 = matrix(M11, M12, M13, M14,
M21, M22, M23, M24,
M31, M32, M33, M34),
@@ -325,7 +303,6 @@
% ---------------------------------------------------------------------------- %
compose_scale(Sx, Sy, Sz, trans(M0, W0)) = trans(M, W) :-
-
( if ( Sx = 0.0 ; Sy = 0.0 ; Sz = 0.0 ) then
throw("trans: compose_scale/7: zero scaling factor")
else
@@ -347,7 +324,6 @@
% ---------------------------------------------------------------------------- %
compose_uscale(S, trans(M0, W0)) = trans(M, W) :-
-
( if S = 0.0 then
throw("trans: compose_uscale/7: zero scaling factor")
else
@@ -369,7 +345,6 @@
% ---------------------------------------------------------------------------- %
compose_rotatex(Rx, trans(M0, W0)) = trans(M, W) :-
-
RRx = degrees_to_radians(Rx),
C = cos(RRx),
S = sin(RRx),
@@ -391,7 +366,6 @@
% ---------------------------------------------------------------------------- %
compose_rotatey(Ry, trans(M0, W0)) = trans(M, W) :-
-
RRy = degrees_to_radians(Ry),
C = cos(RRy),
S = sin(RRy),
@@ -413,7 +387,6 @@
% ---------------------------------------------------------------------------- %
compose_rotatez(Rz, trans(M0, W0)) = trans(M, W) :-
-
RRz = degrees_to_radians(Rz),
C = cos(RRz),
S = sin(RRz),
@@ -438,21 +411,27 @@
% ---------------------------------------------------------------------------- %
-show_trans(trans(M, W)) -->
- { M = matrix(M11, M12, M13, M14,
+show_trans(trans(M, W), !IO) :-
+ M = matrix(M11, M12, M13, M14,
M21, M22, M23, M24,
- M31, M32, M33, M34) },
- { W = matrix(W11, W12, W13, W14,
+ M31, M32, M33, M34),
+ W = matrix(W11, W12, W13, W14,
W21, W22, W23, W24,
- W31, W32, W33, W34) },
- io__format("object -> world space world -> object space\n", []),
- io__format("(%4.1f %4.1f %4.1f %4.1f) ", [f(M11),f(M12),f(M13),f(M14)]),
- io__format("(%4.1f %4.1f %4.1f %4.1f)\n", [f(W11),f(W12),f(W13),f(W14)]),
- io__format("(%4.1f %4.1f %4.1f %4.1f) ", [f(M21),f(M22),f(M23),f(M24)]),
- io__format("(%4.1f %4.1f %4.1f %4.1f)\n", [f(W21),f(W22),f(W23),f(W24)]),
- io__format("(%4.1f %4.1f %4.1f %4.1f) ", [f(M31),f(M32),f(M33),f(M34)]),
- io__format("(%4.1f %4.1f %4.1f %4.1f)\n", [f(W31),f(W32),f(W33),f(W34)]),
- io__format("( 0.0 0.0 0.0 1.0) ( 0.0 0.0 0.0 1.0)\n", []).
+ W31, W32, W33, W34),
+ io.format("object -> world space world -> object space\n", [], !IO),
+ io.format("(%4.1f %4.1f %4.1f %4.1f) ",
+ [f(M11),f(M12),f(M13),f(M14)], !IO),
+ io.format("(%4.1f %4.1f %4.1f %4.1f)\n",
+ [f(W11),f(W12),f(W13),f(W14)], !IO),
+ io.format("(%4.1f %4.1f %4.1f %4.1f) ",
+ [f(M21),f(M22),f(M23),f(M24)], !IO),
+ io.format("(%4.1f %4.1f %4.1f %4.1f)\n",
+ [f(W21),f(W22),f(W23),f(W24)], !IO),
+ io.format("(%4.1f %4.1f %4.1f %4.1f) ",
+ [f(M31),f(M32),f(M33),f(M34)], !IO),
+ io.format("(%4.1f %4.1f %4.1f %4.1f)\n",
+ [f(W31),f(W32),f(W33),f(W34)], !IO),
+ io.format("( 0.0 0.0 0.0 1.0) ( 0.0 0.0 0.0 1.0)\n", [], !IO).
% ---------------------------------------------------------------------------- %
@@ -471,7 +450,6 @@
% to translate it back into world space via the transformation M.
%
intersects_plane(Id, T, P, D, Surface, IntersectionResults) :-
-
% The plane is defined by y =< 0.
% First, translate the world space line into object space.
@@ -520,7 +498,6 @@
% http://www.cs.fit.edu/wds/classes/adv-graphics/raytrace/raytrace.html
%
intersects_sphere(Id, T, P, D, Surface, IntersectionResults) :-
-
% The sphere is defined by x^2 + y^2 + z^2 =< 1.
% First, translate the world space line into object space.
@@ -538,7 +515,6 @@
% the sphere and not emanating from within it.
%
( not ( SqrLoc > 1.0, Tca < 0.0 ) ->
-
SqrTca = Tca * Tca,
SqrD = SqrLoc - SqrTca,
SqrThc = 1.0 - SqrD,
@@ -547,7 +523,6 @@
% intersect with the sphere.
%
( SqrThc >= 0.0 ->
-
% Finally, we compute the point of intersection with the sphere.
% If SqrLoc >= 1.0 we are outside the sphere, otherwise
% we are inside the sphere.
@@ -569,9 +544,9 @@
IntersectionResults = []
).
-:- pred intersects_sphere_2(object_id, real, trans, real, real, real, real,
- real, real, surface, intersection).
-:- mode intersects_sphere_2(in, in, in, in, in, in, in, in, in, in, out) is det.
+:- pred intersects_sphere_2(object_id::in, real::in, trans::in, real::in,
+ real::in, real::in, real::in, real::in, real::in, surface::in,
+ intersection::out) is det.
intersects_sphere_2(Id, DistToSurface, T, X, Y, Z, Dx, Dy, Dz, Surface,
Intersection) :-
@@ -619,7 +594,6 @@
% http://www.cs.fit.edu/wds/classes/adv-graphics/raytrace/raytrace.html
%
intersects_cube(Id, T, P, D, Surface, IntersectionResults) :-
-
% The cube is defined by 0 =< x,y,z =< 1.
% First, translate the world space line into object space.
@@ -635,8 +609,7 @@
% y = 1 (face 4)
% y = 0 (face 5)
%
- % We need to find the nearest point of intersection
- % if there is one.
+ % We need to find the nearest point of intersection if there is one.
%
Face0Intersection = z_face_intersection(0, 0.0, X, Y, Z, Dx, Dy, Dz),
Face1Intersection = z_face_intersection(1, 1.0, X, Y, Z, Dx, Dy, Dz),
@@ -645,10 +618,10 @@
Face4Intersection = y_face_intersection(4, 1.0, X, Y, Z, Dx, Dy, Dz),
Face5Intersection = y_face_intersection(5, 0.0, X, Y, Z, Dx, Dy, Dz),
- FaceIntersections = list__condense([Face0Intersection,
+ FaceIntersections = list.condense([Face0Intersection,
Face1Intersection, Face2Intersection, Face3Intersection,
Face4Intersection, Face5Intersection]),
- IntersectionResults = list__map(process_cube_intersections(Id, T, Surface),
+ IntersectionResults = list.map(process_cube_intersections(Id, T, Surface),
FaceIntersections).
:- func process_cube_intersections(object_id, trans, surface,
@@ -760,7 +733,6 @@
% to translate it back into world space via the transformation M.
%
intersects_cylinder(Id, T, P, D, Surface, IntersectionResults) :-
-
% The cylinder is defined by 0 =< y =< 1, x^2 + z^2 =< 1.
% First, translate the world space line into object space.
@@ -777,9 +749,9 @@
Face1Intersections = disc_intersection(1, 1.0, X, Y, Z, Dx, Dy, Dz),
Face2Intersections = disc_intersection(2, 0.0, X, Y, Z, Dx, Dy, Dz),
- FaceIntersections = list__condense([Face0Intersections,
+ FaceIntersections = list.condense([Face0Intersections,
Face1Intersections, Face2Intersections]),
- IntersectionResults = list__map(process_cylinder_intersections(Id, T,
+ IntersectionResults = list.map(process_cylinder_intersections(Id, T,
Surface), FaceIntersections).
:- func process_cylinder_intersections(object_id, trans, surface,
@@ -809,7 +781,6 @@
% ---------------------------------------------------------------------------- %
intersects_cone(Id, T, P, D, Surface, IntersectionResults) :-
-
% The cone is defined by 0 =< y =< 1, x^2 + z^2 - y^2 =< 1.
% First, translate the world space line into object space.
@@ -824,8 +795,8 @@
Face0Intersections = cone_intersection(0, X, Y, Z, Dx, Dy, Dz),
Face1Intersections = disc_intersection(1, 1.0, X, Y, Z, Dx, Dy, Dz),
- FaceIntersections = list__append(Face1Intersections, Face0Intersections),
- IntersectionResults = list__map(process_cone_intersections(Id, T, Surface),
+ FaceIntersections = list.append(Face1Intersections, Face0Intersections),
+ IntersectionResults = list.map(process_cone_intersections(Id, T, Surface),
FaceIntersections).
:- func process_cone_intersections(object_id, trans, surface,
@@ -857,31 +828,29 @@
:- func cylinder_intersection(int, float, float, float, float, float, float) =
face_intersections.
-cylinder_intersection(Face, X, Y, Z, Dx, Dy, Dz) =
- solve_quadratic(Face, X, Y, Z, Dx, Dy, Dz, A, B, C)
- :-
+cylinder_intersection(Face, X, Y, Z, Dx, Dy, Dz) = Intersections :-
A = (Dx * Dx) + (Dz * Dz),
B = 2.0 * ((X * Dx) + (Z * Dz)),
- C = (X * X) + (Z * Z) - 1.0.
+ C = (X * X) + (Z * Z) - 1.0,
+ Intersections = solve_quadratic(Face, X, Y, Z, Dx, Dy, Dz, A, B, C).
% ---------------------------------------------------------------------------- %
:- func cone_intersection(int, float, float, float, float, float, float) =
face_intersections.
-cone_intersection(Face, X, Y, Z, Dx, Dy, Dz) =
- solve_quadratic(Face, X, Y, Z, Dx, Dy, Dz, A, B, C)
- :-
+cone_intersection(Face, X, Y, Z, Dx, Dy, Dz) = Intersections :-
A = (Dx * Dx) + (Dz * Dz) - (Dy * Dy),
B = 2.0 * ((X * Dx) + (Z * Dz) - (Y * Dy)),
- C = (X * X) + (Z * Z) - (Y * Y).
+ C = (X * X) + (Z * Z) - (Y * Y),
+ Intersections = solve_quadratic(Face, X, Y, Z, Dx, Dy, Dz, A, B, C).
% ---------------------------------------------------------------------------- %
:- func solve_quadratic(int, float, float, float, float, float, float, float,
float, float) = face_intersections.
-solve_quadratic(Face, X, Y, Z, Dx, Dy, Dz, A, B, C) = Intersections :-
+solve_quadratic(Face, X, Y, Z, Dx, Dy, Dz, A, B, C) = Intersections :-
% Optimized quadratic solution from "Numerical Recipes in Pascal".
%
BB4AC = B * B - 4.0 * A * C,
@@ -899,11 +868,11 @@
).
:- pred maybe_add_intersection(float::in, int::in, float::in, float::in,
- float::in, float::in, float::in, float::in, face_intersections::in,
- face_intersections::out) is det.
+ float::in, float::in, float::in, float::in,
+ face_intersections::in, face_intersections::out) is det.
-maybe_add_intersection(K, Face, X, Y, Z, Dx, Dy, Dz, Intersections0,
- Intersections) :-
+maybe_add_intersection(K, Face, X, Y, Z, Dx, Dy, Dz,
+ Intersections0, Intersections) :-
(
K >= 0.0,
IY = Y + K * Dy,
Index: icfp2000_par/transform.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/transform.m,v
retrieving revision 1.1
diff -u -b -r1.1 transform.m
--- icfp2000_par/transform.m 10 Nov 2008 03:58:08 -0000 1.1
+++ icfp2000_par/transform.m 10 Nov 2008 07:25:04 -0000
@@ -1,9 +1,14 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
% Basic geometric transformations.
:- module transform.
:- interface.
-:- import_module eval, vector.
+:- import_module eval.
+:- import_module vector.
% translate(Point, Tx, Ty, Tz) = TranslatedPoint.
:- func translate(point, float, float, float) = point.
@@ -25,7 +30,8 @@
:- implementation.
-:- import_module float, math.
+:- import_module float.
+:- import_module math.
translate(point(X, Y, Z), Tx, Ty, Tz) = point(X + Tx, Y + Ty, Z + Tz).
@@ -51,7 +57,6 @@
cos_and_sin(Degrees, Cos, Sin) :-
% XXX It might be worth doing this conversion when the angle is
% read in to avoid doing multiple conversions.
- Radians = Degrees / (2.0 * math__pi),
- Cos = math__cos(Radians),
- Sin = math__sin(Radians).
-
+ Radians = Degrees / (2.0 * math.pi),
+ Cos = math.cos(Radians),
+ Sin = math.sin(Radians).
Index: icfp2000_par/transform_object.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/transform_object.m,v
retrieving revision 1.1
diff -u -b -r1.1 transform_object.m
--- icfp2000_par/transform_object.m 10 Nov 2008 03:58:08 -0000 1.1
+++ icfp2000_par/transform_object.m 11 Nov 2008 00:07:12 -0000
@@ -1,3 +1,7 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
% ---------------------------------------------------------------------------- %
%
% This module applies all the transformations to an
@@ -11,22 +15,21 @@
:- import_module eval.
-
-
% Compose all the transformations applied to an object
% into a single transformation matrix (and it's inverse).
%
:- func push_transformations(object) = object.
-
-
% ---------------------------------------------------------------------------- %
% ---------------------------------------------------------------------------- %
:- implementation.
:- import_module trans.
-:- import_module list, exception, require.
+
+:- import_module list.
+:- import_module exception.
+:- import_module require.
% ---------------------------------------------------------------------------- %
@@ -69,11 +72,7 @@
:- func compose_transformations(list(transformation)) = trans.
compose_transformations(Transformations) =
- list__foldl(
- compose_transformation,
- Transformations,
- identity
- ).
+ list.foldl(compose_transformation, Transformations, identity).
:- func compose_transformation(transformation, trans) = trans.
Index: icfp2000_par/tree.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/tree.m,v
retrieving revision 1.1
diff -u -b -r1.1 tree.m
--- icfp2000_par/tree.m 10 Nov 2008 03:58:08 -0000 1.1
+++ icfp2000_par/tree.m 11 Nov 2008 00:01:02 -0000
@@ -1,3 +1,7 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
%-----------------------------------------------------------------------------%
% Copyright (C) 1993-1999 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
@@ -19,49 +23,48 @@
:- interface.
:- import_module list.
-:- type tree(T) ---> empty
+:- type tree(T)
+ ---> empty
; node(T)
; tree(tree(T), tree(T)).
-:- pred tree__flatten(tree(T), list(T)).
-:- mode tree__flatten(in, out) is det.
+:- pred tree.flatten(tree(T)::in, list(T)::out) is det.
-:- pred tree__is_empty(tree(T)).
-:- mode tree__is_empty(in) is semidet.
+:- pred tree.is_empty(tree(T)::in) is semidet.
-:- pred tree__tree_of_lists_is_empty(tree(list(T))).
-:- mode tree__tree_of_lists_is_empty(in) is semidet.
+:- pred tree.tree_of_lists_is_empty(tree(list(T))::in) is semidet.
%-----------------------------------------------------------------------------%
:- implementation.
-tree__flatten(T, L) :-
- tree__flatten_2(T, [], L).
+tree.flatten(T, L) :-
+ tree.flatten_2(T, [], L).
-:- pred tree__flatten_2(tree(T), list(T), list(T)).
-:- mode tree__flatten_2(in, in, out) is det.
% flatten_2(T, L0, L) is true iff L is the list that results from
% traversing T left-to-right depth-first, and then appending L0.
-tree__flatten_2(empty, L, L).
-tree__flatten_2(node(T), L, [T|L]).
-tree__flatten_2(tree(T1,T2), L0, L) :-
- tree__flatten_2(T2, L0, L1),
- tree__flatten_2(T1, L1, L).
+ %
+:- pred tree.flatten_2(tree(T)::in, list(T)::in, list(T)::out) is det.
+
+tree.flatten_2(empty, L, L).
+tree.flatten_2(node(T), L, [T | L]).
+tree.flatten_2(tree(T1, T2), L0, L) :-
+ tree.flatten_2(T2, L0, L1),
+ tree.flatten_2(T1, L1, L).
%-----------------------------------------------------------------------------%
-tree__is_empty(empty).
-tree__is_empty(tree(L, R)) :-
- tree__is_empty(L),
- tree__is_empty(R).
+tree.is_empty(empty).
+tree.is_empty(tree(L, R)) :-
+ tree.is_empty(L),
+ tree.is_empty(R).
%-----------------------------------------------------------------------------%
-tree__tree_of_lists_is_empty(empty).
-tree__tree_of_lists_is_empty(node([])).
-tree__tree_of_lists_is_empty(tree(L, R)) :-
- tree__tree_of_lists_is_empty(L),
- tree__tree_of_lists_is_empty(R).
+tree.tree_of_lists_is_empty(empty).
+tree.tree_of_lists_is_empty(node([])).
+tree.tree_of_lists_is_empty(tree(L, R)) :-
+ tree.tree_of_lists_is_empty(L),
+ tree.tree_of_lists_is_empty(R).
%-----------------------------------------------------------------------------%
Index: icfp2000_par/vector.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/icfp2000_par/vector.m,v
retrieving revision 1.1
diff -u -b -r1.1 vector.m
--- icfp2000_par/vector.m 10 Nov 2008 03:58:08 -0000 1.1
+++ icfp2000_par/vector.m 11 Nov 2008 00:07:34 -0000
@@ -1,3 +1,7 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+
:- module vector.
% a 3D vector module.
@@ -113,7 +117,6 @@
UnitV2 = unit(V2),
Projection = scale(dot(V1, UnitV2), UnitV2).
-
projectXY(point(X, Y, _)) = point(X, Y, 0.0).
projectXZ(point(X, _, Z)) = point(X, 0.0, Z).
cvs diff: Diffing icfp2000_par/examples
cvs diff: Diffing icfp2001
cvs diff: Diffing nuc
cvs diff: Diffing qsort
Index: qsort/qsort_mt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/benchmarks/progs/qsort/qsort_mt.m,v
retrieving revision 1.1
diff -u -b -r1.1 qsort_mt.m
--- qsort/qsort_mt.m 10 Nov 2008 04:08:26 -0000 1.1
+++ qsort/qsort_mt.m 11 Nov 2008 02:07:58 -0000
@@ -14,11 +14,12 @@
:- implementation.
+:- import_module mt.
+
:- import_module int.
:- import_module list.
:- import_module require.
-
-:- import_module mt.
+:- import_module string.
%-----------------------------------------------------------------------------%
@@ -29,45 +30,82 @@
io.command_line_arguments(Args, !IO),
(
- Args = [Mode0]
+ (
+ Args = [ModePrime, RepeatsStr, TimeFileNamePrime],
+ string.to_int(RepeatsStr, RepeatsPrime)
+ ;
+ Args = [ModePrime, RepeatsStr],
+ string.to_int(RepeatsStr, RepeatsPrime),
+ TimeFileNamePrime = ""
+ ;
+ Args = [ModePrime],
+ RepeatsPrime = 1,
+ TimeFileNamePrime = ""
+ )
->
- Mode = Mode0
+ Mode = ModePrime,
+ Repeats = RepeatsPrime,
+ TimeFileName = TimeFileNamePrime
;
error("bad command")
),
impure gettimeofday(Start),
+ run_n_tests(Repeats, Mode, Rands, Sort),
+ impure gettimeofday(End),
+ trace [compile_time(flag("checksort"))] (
+ ( if check_is_sorted(Sort) then
+ true
+ else
+ error("not sorted")
+ )
+ ),
+ % io.write_int(length(Sort), !IO),
+ % take_upto(10, Sort, T), io.print(T, !IO),
+ io.open_output(TimeFileName, Result, !IO),
+ (
+ Result = ok(Stream),
+ io.write_int(Stream, End - Start, !IO),
+ io.nl(Stream, !IO)
+ ;
+ Result = error(Error),
+ io.error_message(Error, Msg),
+ io.write_string(Msg, !IO),
+ io.nl(!IO)
+ ).
+
+:- pred run_n_tests(int::in, string::in, list(int)::in, list(int)::out) is det.
+
+run_n_tests(N, Mode, Rands, Sort) :-
( Mode = "app_seq" ->
- qsortapp_seq(Rands, Sort)
+ qsortapp_seq(Rands, ThisSort)
; Mode = "app_par_deep" ->
- qsortapp_par_deep(Rands, Sort)
+ qsortapp_par_deep(Rands, ThisSort)
; Mode = "app_par_shallow" ->
- qsortapp_par_shallow(Rands, Sort)
+ qsortapp_par_shallow(Rands, ThisSort)
; Mode = "app_par_shallow2" ->
- qsortapp_par_shallow2(Rands, Sort)
+ qsortapp_par_shallow2(Rands, ThisSort)
; Mode = "app_par_limit" ->
- qsortapp_par_limit(Rands, Sort)
+ qsortapp_par_limit(Rands, ThisSort)
; Mode = "acc_seq" ->
- qsortacc_seq(Rands, [], Sort)
+ qsortacc_seq(Rands, [], ThisSort)
; Mode = "acc_par_deep" ->
- qsortacc_par_deep(Rands, [], Sort)
+ qsortacc_par_deep(Rands, [], ThisSort)
; Mode = "acc_par_shallow" ->
- qsortacc_par_shallow(Rands, [], Sort)
+ qsortacc_par_shallow(Rands, [], ThisSort)
+ ; Mode = "acc_par_shallow2" ->
+ qsortacc_par_shallow2(Rands, [], ThisSort)
; Mode = "acc_par_limit" ->
- qsortacc_par_limit(Rands, [], Sort)
+ qsortacc_par_limit(Rands, [], ThisSort)
;
error("bad mode")
),
- impure gettimeofday(End),
- trace [compile_time(flag("checksort"))] (
- if check_is_sorted(Sort)
- then true
- else error("not sorted")
- ),
- %io.write_int(length(Sort), !IO),
- %take_upto(10, Sort, T), io.print(T, !IO),
- io.print(End-Start, !IO),
- io.nl(!IO).
+ NextN = N - 1,
+ ( NextN =< -0 ->
+ Sort = ThisSort
+ ;
+ run_n_tests(NextN, Mode, Rands, Sort)
+ ).
:- impure pred gettimeofday(int::out) is det.
:- pragma foreign_proc("C",
@@ -91,7 +129,7 @@
mt::di, mt::uo) is det.
rand_list_2(N, Acc0, Acc, !MT) :-
- (if N > 0 then
+ ( if N > 0 then
genrand_int32(Rand, !MT),
rand_list_2(N-1, [Rand | Acc0], Acc, !MT)
else
@@ -103,7 +141,7 @@
:- pred qsortapp_seq(list(int)::in, list(int)::out) is det.
qsortapp_seq([], []).
-qsortapp_seq([Pivot|T], List) :-
+qsortapp_seq([Pivot | T], List) :-
partition(Pivot, T, [], Left0, [], Right0),
qsortapp_seq(Left0, Left),
qsortapp_seq(Right0, Right),
@@ -112,7 +150,7 @@
:- pred qsortapp_par_deep(list(int)::in, list(int)::out) is det.
qsortapp_par_deep([], []).
-qsortapp_par_deep([Pivot|T], List) :-
+qsortapp_par_deep([Pivot | T], List) :-
partition(Pivot, T, [], Left0, [], Right0),
( qsortapp_par_deep(Left0, Left)
& qsortapp_par_deep(Right0, Right)
@@ -122,7 +160,7 @@
:- pred qsortapp_par_shallow(list(int)::in, list(int)::out) is det.
qsortapp_par_shallow([], []).
-qsortapp_par_shallow([Pivot|T], List) :-
+qsortapp_par_shallow([Pivot | T], List) :-
partition(Pivot, T, [], Left0, [], Right0),
( qsortapp_seq(Left0, Left)
& qsortapp_seq(Right0, Right)
@@ -133,7 +171,7 @@
:- pred qsortapp_par_shallow2(list(int)::in, list(int)::out) is det.
qsortapp_par_shallow2([], []).
-qsortapp_par_shallow2([Pivot|T], List) :-
+qsortapp_par_shallow2([Pivot | T], List) :-
partition(Pivot, T, [], Left0, [], Right0),
( qsortapp_par_shallow(Left0, Left)
& qsortapp_par_shallow(Right0, Right)
@@ -145,10 +183,10 @@
min_par_limit_length = 5000.
:- pred qsortapp_par_limit(list(int)::in, list(int)::out) is det.
-:- pragma promise_pure(qsortapp_par_limit/2).
+% :- pragma promise_pure(qsortapp_par_limit/2).
qsortapp_par_limit([], []).
-qsortapp_par_limit([Pivot|T], List) :-
+qsortapp_par_limit([Pivot | T], List) :-
% impure gettimeofday(P0),
partition_lr(Pivot, T,
[], Left0, [], Right0,
@@ -182,7 +220,7 @@
:- pred qsortacc_seq(list(int)::in, list(int)::in, list(int)::out) is det.
qsortacc_seq([], Acc, Acc).
-qsortacc_seq([Pivot|T], Acc0, Acc) :-
+qsortacc_seq([Pivot | T], Acc0, Acc) :-
partition(Pivot, T, [], Left0, [], Right0),
qsortacc_seq(Right0, Acc0, Right),
qsortacc_seq(Left0, [Pivot | Right], Acc).
@@ -191,7 +229,7 @@
is det.
qsortacc_par_shallow([], Acc, Acc).
-qsortacc_par_shallow([Pivot|T], Acc0, Acc) :-
+qsortacc_par_shallow([Pivot | T], Acc0, Acc) :-
partition(Pivot, T, [], Left0, [], Right0),
(
qsortacc_seq(Right0, Acc0, Right),
@@ -200,10 +238,23 @@
qsortacc_seq(Left0, PivotRight, Acc)
).
+:- pred qsortacc_par_shallow2(list(int)::in, list(int)::in, list(int)::out)
+ is det.
+
+qsortacc_par_shallow2([], Acc, Acc).
+qsortacc_par_shallow2([Pivot | T], Acc0, Acc) :-
+ partition(Pivot, T, [], Left0, [], Right0),
+ (
+ qsortacc_par_shallow(Right0, Acc0, Right),
+ PivotRight = [Pivot | Right]
+ &
+ qsortacc_par_shallow(Left0, PivotRight, Acc)
+ ).
+
:- pred qsortacc_par_deep(list(int)::in, list(int)::in, list(int)::out) is det.
qsortacc_par_deep([], Acc, Acc).
-qsortacc_par_deep([Pivot|T], Acc0, Acc) :-
+qsortacc_par_deep([Pivot | T], Acc0, Acc) :-
partition(Pivot, T, [], Left0, [], Right0),
(
qsortacc_par_deep(Right0, Acc0, Right),
@@ -218,7 +269,7 @@
:- pred qsortacc_par_limit(list(int)::in, list(int)::in, list(int)::out) is det.
qsortacc_par_limit([], Acc, Acc).
-qsortacc_par_limit([Pivot|T], Acc0, Acc) :-
+qsortacc_par_limit([Pivot | T], Acc0, Acc) :-
partition_lr(Pivot, T,
[], Left0, [], Right0,
0, LeftCount, 0, RightCount),
@@ -248,14 +299,14 @@
% qsort_acc(U, [], S).
%
% qsort_acc([], Acc, Acc).
-% qsort_acc([Pivot|T], Acc, List) :-
+% qsort_acc([Pivot | T], Acc, List) :-
% partition(Pivot, T, [], Left0, [], Right0, 0, N),
-% (if N > gran then
+% ( if N > gran then
% qsort_acc(Right0, Acc, Right) &
-% qsort_acc(Left0, [Pivot|Right], List)
+% qsort_acc(Left0, [Pivot | Right], List)
% else
% qsort_acc(Right0, Acc, Right),
-% qsort_acc(Left0, [Pivot|Right], List)
+% qsort_acc(Left0, [Pivot | Right], List)
% ).
% :- pred qsort_acc1(list(int)::in, list(int)::out) is det.
@@ -265,18 +316,18 @@
% qsort_acc1(U, [], S).
%
% qsort_acc1([], Acc, Acc).
-% qsort_acc1([Pivot|T], Acc, List) :-
+% qsort_acc1([Pivot | T], Acc, List) :-
% partition(Pivot, T, [], Left0, [], Right0, 0, N),
-% (if N > gran then
+% ( if N > gran then
% (
% qsort_acc1(Right0, Acc, Right),
-% PivotRight = [Pivot|Right]
+% PivotRight = [Pivot | Right]
% &
% qsort_acc1(Left0, PivotRight, List)
% )
% else
% qsort_acc1(Right0, Acc, Right),
-% qsort_acc1(Left0, [Pivot|Right], List)
+% qsort_acc1(Left0, [Pivot | Right], List)
% ).
% :- pred qsort_acc1b(list(int)::in, list(int)::out) is det.
@@ -286,11 +337,11 @@
% qsort_acc1b(U, [], S).
%
% qsort_acc1b([], Acc, Acc).
-% qsort_acc1b([Pivot|T], Acc, List) :-
+% qsort_acc1b([Pivot | T], Acc, List) :-
% partition(Pivot, T, [], Left0, [], Right0, 0, N),
% (
% qsort_acc1b(Right0, Acc, Right),
-% PivotRight = [Pivot|Right]
+% PivotRight = [Pivot | Right]
% &
% qsort_acc1b(Left0, PivotRight, List)
% ).
@@ -304,7 +355,7 @@
% qsort_acc1c(U, [], S).
%
% qsort_acc1c([], Acc, Acc).
-% qsort_acc1c([Pivot|T], Acc, List) :-
+% qsort_acc1c([Pivot | T], Acc, List) :-
% partition_lr(Pivot, T, [], Left0, [], Right0, 0, L, 0, R),
% (
% L > 5000,
@@ -312,13 +363,13 @@
% ->
% (
% qsort_acc1c(Right0, Acc, Right),
-% PivotRight = [Pivot|Right]
+% PivotRight = [Pivot | Right]
% &
% qsort_acc1c(Left0, PivotRight, List)
% )
% ;
% qsort_acc1c(Right0, Acc, Right),
-% qsort_acc1c(Left0, [Pivot|Right], List)
+% qsort_acc1c(Left0, [Pivot | Right], List)
% ).
:- pred partition(int::in, list(int)::in, list(int)::in, list(int)::out,
@@ -326,7 +377,7 @@
partition(_Pivot, [], Left, Left, Right, Right).
partition(Pivot, [H | T], Left0, Left, Right0, Right) :-
- (if H < Pivot then
+ ( if H < Pivot then
partition(Pivot, T, [H | Left0], Left, Right0, Right)
else
partition(Pivot, T, Left0, Left, [H | Right0], Right)
@@ -338,10 +389,10 @@
partition_lr(_Pivot, [], Left, Left, Right, Right, L, L, R, R).
partition_lr(Pivot, [H | T], Left0, Left, Right0, Right, L0, L, R0, R) :-
- (if H < Pivot then
- partition_lr(Pivot, T, [H|Left0], Left, Right0, Right, L0+1,L, R0,R)
+ ( if H < Pivot then
+ partition_lr(Pivot, T, [H | Left0], Left, Right0, Right, L0+1,L, R0,R)
else
- partition_lr(Pivot, T, Left0, Left, [H|Right0], Right, L0,L, R0+1,R)
+ partition_lr(Pivot, T, Left0, Left, [H | Right0], Right, L0,L, R0+1,R)
).
%-----------------------------------------------------------------------------%
@@ -350,7 +401,7 @@
:- pred check_is_sorted(int::in, list(int)::in) is semidet.
check_is_sorted([]).
-check_is_sorted([H|T]) :-
+check_is_sorted([H | T]) :-
check_is_sorted(H, T).
check_is_sorted(_, []).
cvs diff: Diffing ray
cvs diff: Diffing ray2
cvs diff: Diffing tree234
cvs diff: Diffing tsp
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list