{$Mode objfpc}
program traveller;
uses
GGI,
GGIGraph,
Crt;
{wincrt only for readkey}
type
pt = object
x, y: int64;
end;
type
pts = object
p: array of pt;
index: int64;
end;
var
copy: array of pts; {global variable}
function range(First: integer; last: integer): integer;
begin
Result := trunc(Random() * (last - First + 1)) + First;
end; {range}
procedure setup(var points: pts; n: integer; xres: word; yres: word);
var
i: integer;
begin
if high(points.p) = -1 then
setlength(points.p, n);
for i := 0 to high(points.p) do
begin
points.p[i].x := range(20, (xres) - 20);
points.p[i].y := range(80, (yres) - 20);
end;
end; {setup}
procedure drawpoints(points: pts);
var
c: string;
var
i: integer;
begin
for i := 0 to high(points.p) do
begin
if i = 0 then
setfillstyle(solidfill, white)
else
setfillstyle(solidfill, red);
if i = high(points.p) then
setfillstyle(solidfill, green);
fillellipse(points.p[i].x, points.p[i].y, 10, 10);
str((i + 1), c);
OutTextXY(points.p[i].x, points.p[i].y + 15, c);
end;
end; {drawpoints}
procedure join(points: pts);
var
i: integer;
begin
drawpoints(points);
for i := 0 to high(points.p) - 1 do
line(points.p[i].x, points.p[i].y, points.p[i + 1].x, points.p[i + 1].y);
end; {join}
procedure fasttrack(var points: pts);
var
min: int64 = 20000000;
var
ctr, total, runs, x, y: int64;
var
sz: longword = 0;
var
i: longword; {for loops}
var
L, vmin: int64;
function length(a: pt; b: pt): int64;
begin
Result := (a.x - b.x) * (a.x - b.x) + (a.y - b.y) * (a.y - b.y);
end;{length -- nested}
procedure swaps(var p1: pt; var p2: pt);
var
tmp: pt;
begin
tmp := p1;
p1 := p2;
p2 := tmp;
end;{swaps -- nested}
begin
vmin := 0;
total := 0;
ctr := 0;
sz := high(points.p);
runs := 2000000; {iterations}
if high(copy) = -1 then
begin
setlength(copy, runs); {allocate}
for i := 0 to runs do
setlength(copy[i].p, sz); {allocate}
end;
repeat
repeat
x := Range(1, sz - 1);
y := Range(1, sz - 1);
until x <> y;
swaps(points.p[x], points.p[y]);
total := 0;
inc(ctr);
for i := 0 to sz - 1 do
begin
L := length(points.p[i], points.p[i + 1]);
inc(total,L);
end; {for}
for i := 0 to high(points.p) do
begin
copy[ctr].p[i].x := points.p[i].x;
copy[ctr].p[i].y := points.p[i].y;
end;{for}
copy[ctr].index := total;
if min > total then
min := total;
until ctr >= runs;
for i := 0 to high(copy) do
if copy[i].index = min then
Vmin := i;
for i := 0 to high(points.p) do
begin
points.p[i].x := copy[vmin].p[i].x;
points.p[i].y := copy[vmin].p[i].y;
end;
end; {fasttrack}
function distance(points: pts): int64;
var
total, L: int64;
var
n: longint;
function length(a: pt; b: pt): int64;
begin
Result := trunc(sqrt((a.x - b.x) * (a.x - b.x) + (a.y - b.y) * (a.y - b.y)));
end;
{length -- nested}
begin
total := 0;
for n := 0 to high(points.p) - 1 do
begin
L := length(points.p[n], points.p[n + 1]);
inc(total,L);;
end;
Result := total;
end; {distance}
var
c: char;
var
gd, gm: smallint;
var
points: pts;
var
distance1: int64;
var
d1: string;
begin
{========== set up graph =========}
gd := D8bit;
gm := m800x600;
InitGraph(gd, gm, '');
if GraphResult <> grok then
halt;
SetTextStyle(SansSerifFont, HorizDir, 2);
setbkcolor(3);
{===================================}
// randomize;
repeat
setup(points, 12, 800, 600);
Cleardevice;
setcolor(blue);
join(points);
distance1 := distance(points);
str(distance1, d1);
OutTextXY(10, 10, 'Through distance, white to green ' + d1);
OutTextXY(10, 30, 'Press a key ');
c := readkey;
cleardevice;
OutTextXY(10, 10, 'Press a key to redo, esc to end');
fasttrack(points); {do the business here }
setcolor(white);
join(points);
OutTextXY(10, 30, 'Old distsnce ' + d1);
distance1 := distance(points);
str(distance1, d1);
OutTextXY(10, 50, 'New distsnce ' + d1);
c := readkey;
until c = #27;
Closegraph;
end.
Recent
