71 lines
1.3 KiB
Text
71 lines
1.3 KiB
Text
(* Dutch national flag problem *)
|
|
|
|
block
|
|
const
|
|
c_blue = 0, c_white = 1, c_red = 2,
|
|
n = 20;
|
|
var
|
|
i: integer,
|
|
t: arrayof integer;
|
|
|
|
unit writeln_color_seq: procedure (t: arrayof integer);
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := lower(t) to upper(t)
|
|
do
|
|
case t(i)
|
|
when c_blue:
|
|
write("B");
|
|
when c_white:
|
|
write("W");
|
|
when c_red:
|
|
write("R");
|
|
esac;
|
|
od;
|
|
writeln;
|
|
end writeln_color_seq;
|
|
|
|
unit swap: procedure (inout a, b: integer);
|
|
var
|
|
tmp: integer;
|
|
begin
|
|
tmp := a;
|
|
a := b;
|
|
b := tmp
|
|
end swap;
|
|
|
|
unit sort_by_color: procedure (t: arrayof integer);
|
|
var
|
|
b, w, r: integer;
|
|
begin
|
|
b, w := lower(t);
|
|
r := upper(t);
|
|
while (w <= r)
|
|
do
|
|
case t(w)
|
|
when c_white:
|
|
w := w + 1;
|
|
when c_blue:
|
|
call swap(t(b), t(w));
|
|
b := b + 1;
|
|
w := w + 1;
|
|
when c_red:
|
|
call swap(t(w), t(r));
|
|
r := r - 1;
|
|
esac
|
|
od;
|
|
end sort_by_color;
|
|
|
|
begin
|
|
array t dim (0 : n - 1);
|
|
|
|
(* Set colors *)
|
|
for i := 0 to n - 1 do t(i) := entier(random * 3) od;
|
|
writeln("Unsorted:");
|
|
call writeln_color_seq(t);
|
|
call sort_by_color(t);
|
|
writeln;
|
|
writeln("Sorted:");
|
|
call writeln_color_seq(t);
|
|
end;
|