|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 15872 (0x3e00)
Types: TextFile
Names: »KT3.PAS«
└─⟦cd307176b⟧ Bits:30002666 Programmer fra Forlaget FAG ApS
└─ ⟦this⟧ »KT3.PAS«
program transport; (* TB jan 1985 Compas Pascal v. 3.07, Piccoline *)
const max=40; (* (c) Forlaget FAG, Frederikssund *)
type maxrange = 0..max;
doublerange = 0..80;
elements =
record
visited, stone:boolean;
unitcost: real;
unitamount : real;
end;
path =
record
icord: maxrange;
jcord: maxrange;
end;
transarray = array(.maxrange,maxrange.) of elements;
headerarray= array(.maxrange.) of real;
tracearray = array(.doublerange.) of path;
var table: transarray;
rowhead,columnhead: headerarray;
source,destination: headerarray;
lastsource,lastdestin: maxrange;
rlastsource,rlastdestin: real;
totalsource, totaldestin: real;
s,t,row,col,i,j,extra: integer;
leastindex: real;
trace: tracearray;
numstones,laststone, count: doublerange;
leastamount: real;
svar:char;
fil:string(.12.);
outf:text;
fil1:file of real;
prt: boolean;
procedure forklaring;
begin
writeln(clrhom);writeln;
writeln(' *******************************************************');
writeln(' * DETTE PROGRAM LØSER DET KLASSISKE TRANSPORTPROBLEM *');
writeln(' * MAN SKAL ANGIVE HVOR MANGE AFSENDERE (SOURCES) *');
writeln(' * MAN HAR TIL RÅDIGHED, OG HVOR MANGE MODTAGERE *');
writeln(' * (DESTINATIONS), DER SKAL VÆRE. *');
writeln(' * *');
writeln(' * FOR HVER AFSENDER ANFØRES HVOR MEGET, DER SKAL *');
writeln(' * LEVERES. FOR HVER MODTAGER ANFØRES HVOR MEGET, *');
writeln(' * DER SKAL MODTAGES. *');
writeln(' * *');
writeln(' * TIL SLUT ANGIVES TRANSPORTPRISEN PR ENHED *');
writeln(' * FRA ENHVER AFSENDER TIL ENHVER MODTAGER. *');
writeln(' * *');
writeln(' * HVIS UDBUDDET IKKE SVARER TIL EFTERSPØRGSLEN *');
writeln(' * OPRETTES ENTEN EN EKSTRA AFSENDER ELLER EN *');
writeln(' * EKSTRA MODTAGER. DETTE OPLYSES UNDER KØRSLEN *');
writeln(' * AF PROGRAMMET. *');
writeln(' * *');
writeln(' * (c) Tommy Borch *');
writeln(' * Forlaget FAG December 1983. *');
writeln(' *******************************************************');
writeln;
write(' Tast return > '); readln(svar);
end; (* forklaring *)
procedure uddata;
var i,j,t: integer;
begin t:=0;
writeln(clrhom);
if prt then writeln(outf,@12);
if len(fil)>0 then writeln(outf,' ':10,'FIL : ',fil:14);
writeln(outf);
for i:=1 to 79 do write(outf,'-');
writeln(outf); writeln(outf);
writeln(outf,' Transportpriser/enhed');
writeln(outf);
for i:=1 to lastsource do
for j:=1 to lastdestin do
begin write(outf,table(.i,j.).unitcost:10:2);
t:=t+1;
if t >= 8 then begin t:=0; writeln(outf); end;
end;
writeln(outf); writeln(outf);
writeln(outf,' Leverancer fra afsendere');
writeln(outf);
for i:=1 to lastsource do write(outf,source(.i.):10:2);
writeln(outf);writeln(outf);
writeln(outf,' Efterspørgsel fra modtagere');
writeln(outf);
for j:=1 to lastdestin do write(outf,destination(.j.):10:2);
writeln(outf); writeln(outf);
end;
procedure printer;
begin
close(outf);
write(' Ønskes udskrift på skærm/printer? (s/p) ');
readln(svar); writeln;
if svar in (.'p','P'.) then
begin
assign(outf,'LST:');rewrite(outf);
prt:=true; uddata;
end
else begin
assign(outf,'CON:');reset(outf); prt:=false;
end;
end; (* printer *)
procedure retdata;
var svar:char;
begin write(' Ønskes rettelser? (j/n) ');
readln(svar); writeln;
if svar in (.'j','J'.) then
begin
repeat
writeln;
writeln(' Rettelser i : (1) Leverancer ');
writeln(' (2) Efterspørgsel');
writeln(' (3) Transportpriser');
writeln(' (4) Stop rettelser');
repeat
write(' Vælg bogstav > ');
read(svar);
until svar in (.'1','2','3','4'.);
writeln;
case svar of
'1':begin
write(' Anfør afsender nummer ');
readln(i);
write(' afsender ',i,' = ');
write(source(.i.):6:2,' = ');
readln(source(.i.));
end;
'2':begin
write(' Anfør modtager nummer ');
readln(j);
write(' modtager ',j,' = ');
write(destination(.j.):6:2,' = ');
readln(destination(.j.));
end;
'3':begin
write(' Anfør afsender nummer ');
readln(i);
write(' Anfør modtager nummer ');
readln(j);
write(' Transportpris = ');
write(table(.i,j.).unitcost:6:2,' = ');
readln(table(.i,j.).unitcost);
end;
end;
until svar = '4';
uddata;
end;
end; (* retdata *)
procedure hentdata;
var ok: boolean;
begin
assign(outf,'CON:'); reset(outf);
repeat
write(' Hvad er filens navn? (højst 8 bogstaver) ');
buflen:=8; readln(fil); writeln;
fil:=fil+'.KTD';
assign(fil1,fil);
(*$I-*) reset(fil1);(*$I+*)
ok:=iores=0;
if not ok then writeln(' FEJL. FILEN FINDES IKKE. PRØV IGEN!');
until ok;
read(fil1,rlastsource,rlastdestin);
lastsource:=trunc(rlastsource);lastdestin:=trunc(rlastdestin);
for i:=1 to lastsource do
for j:=1 to lastdestin do read(fil1,table(.i,j.).unitcost);
for i:=1 to lastsource do read(fil1,source(.i.));
for j:=1 to lastdestin do read(fil1,destination(.j.));
close(fil1);
extra:=0;
for i:=1 to lastsource do
for j:=1 to lastdestin do
begin table(.i,j.).stone:=false;
table(.i,j.).visited:=false;
table(.i,j.).unitamount:=0;
end;
end; (* hentdata *)
procedure gemdata;
begin
write(' Skal disse data gemmes på en fil? (j/n) ');
svar:='j'; readln(svar); writeln;
if svar in (.'j','J'.) then
begin
repeat
write(' Hvad er filens navn? (højst 8 bogstaver) ');
buflen:=8; readln(fil); writeln;
until len(fil)<>0;
fil:=fil+'.KTD';
assign(fil1,fil); rewrite(fil1);
rlastsource:=lastsource;rlastdestin:=lastdestin;
write(fil1,rlastsource,rlastdestin);
for i:=1 to lastsource do
for j:=1 to lastdestin do write(fil1,table(.i,j.).unitcost);
for i:=1 to lastsource do write(fil1,source(.i.));
for j:=1 to lastdestin do write(fil1,destination(.j.));
close(fil1);
end;
end; (* gemdata *)
procedure inputdata;
var i,j:maxrange;
inputnum:real;
begin
assign(outf,'CON:'); reset(outf);fil:='';
repeat
writeln;write(' Antal afsendere? ');
readln(lastsource);
until lastsource<=max;
repeat
write(' Antal modtagere? ');
readln(lastdestin);
until lastdestin<=max;
writeln;
extra:=0;
for i:=1 to lastsource do
begin
write(' Leverance fra afsender ',i,' ');
readln(inputnum);
source(.i.):=inputnum;
end;
for j:=1 to lastdestin do
begin
write(' Efterspørgsel fra modtager ',j,' ');
readln(inputnum);
destination(.j.):=inputnum;
end
end;
procedure inputcost;
var i,j:maxrange;
inputnum: real;
begin
writeln; writeln(' Transportomkostninger:');
for i:=1 to lastsource do
for j:=1 to lastdestin do
begin
write(' Fra afsender ',i,' til modtager ',j,' ');
readln(inputnum);
table(.i,j.).unitcost:=inputnum;
table(.i,j.).stone:=false;
table(.i,j.).visited:=false;
table(.i,j.).unitamount:=0;
end
end;
procedure dummy;
var i,j: maxrange;
begin
totalsource:=0; totaldestin:=0;
for i:=1 to lastsource do
totalsource:=totalsource+source(.i.);
for j:=1 to lastdestin do
totaldestin:=totaldestin+destination(.j.);
if totalsource<>totaldestin then
if totalsource > totaldestin then
begin
lastdestin:=lastdestin+1;
extra:=1;
for i:=1 to lastsource do
begin
table(.i,lastdestin.).unitcost:=0;
table(.i,lastdestin.).stone:=false;
table(.i,lastdestin.).unitamount:=0;
table(.i,lastdestin.).visited:=false;
end;
destination(.lastdestin.):=totalsource-totaldestin;
end
else
begin
lastsource:=lastsource+1;
extra:=2;
for j:=1 to lastdestin do
begin
table(.lastsource,j.).unitcost:=0;
table(.lastsource,j.).stone:=false;
table(.lastsource,j.).unitamount:=0;
table(.lastsource,j.).visited:=false;
end;
source(.lastsource.):=totaldestin-totalsource;
end;
numstones:=lastsource+lastdestin-1;
end;
procedure nordvest;
var i,j: maxrange;
srem,drem: real;
begin
i:=1 ; j:=1;
srem:=source(.i.); drem:=destination(.j.);
while (i<=lastsource) and (j<=lastdestin) do
begin
if srem>drem then
begin
table(.i,j.).unitamount:=drem;
table(.i,j.).stone:=true;
srem:=srem-drem; j:=j+1;
if j<= lastdestin then drem:=destination(.j.);
end
else
if srem<drem then
begin
table(.i,j.).unitamount:=srem;
table(.i,j.).stone:=true;
drem:=drem-srem; i:=i+1;
if i<= lastsource then srem:=source(.i.);
end
else
begin
table(.i,j.).unitamount:=srem;
table(.i,j.).stone:=true; j:=j+1;
if j<= lastdestin then
begin
table(.i,j.).stone:=true;
drem:=destination(.j.)
end;
i:=i+1;
if i<= lastsource then srem:=source(.i.);
end;
end;(* while *)
end;
procedure dorow(i,prevcol:maxrange); forward;
procedure docol(prevrow,j:maxrange);
var i: maxrange;
begin
i:=0;
while (i<lastsource) and (count<numstones) do
begin
i:=i+1;
if table(.i,j.).stone and (i<>prevrow) then
begin
count:=count+1;
rowhead(.i.):=table(.i,j.).unitcost-columnhead(.j.);
dorow(i,j)
end;
end;
end;
procedure dorow;
var j: maxrange;
begin
j:=0;
while (j<lastdestin) and (count<numstones) do
begin
j:=j+1;
if table(.i,j.).stone and (j<>prevcol) then
begin
count:=count+1;
columnhead(.j.):=table(.i,j.).unitcost-rowhead(.i.);
docol(i,j)
end;
end;
end;
procedure improveindex;
var i,j: integer;
index: real;
begin
leastindex:=0;
for i:=1 to lastsource do
for j:=1 to lastdestin do
begin
if not table(.i,j.).stone then
begin
index:=table(.i,j.).unitcost-rowhead(.i.)-columnhead(.j.);
if index<leastindex then
begin
leastindex:=index;
row:=i; col:=j;
end;
end;
end;
end;
function nextcolumn(i,prevcol:maxrange):boolean; forward;
function nextrow(prevrow,j:maxrange):boolean;
var i: maxrange;
token: boolean;
begin
i:=1; token:=false;
repeat
if (table(.i,j.).stone and not table(.i,j.).visited) then
begin
table(.i,j.).visited:=true;
token:=nextcolumn(i,j);
if token then
begin
laststone:=laststone+1;
trace(.laststone.).icord:=i;
trace(.laststone.).jcord:=j;
if table(.i,j.).unitamount<leastamount then
leastamount:=table(.i,j.).unitamount;
end;
table(.i,j.).visited:=false;
end;
i:=i+1;
until (i>lastsource) or token;
nextrow:=token;
end;
function nextcolumn;
var j: maxrange;
token: boolean;
begin
j:=1; token:=false;
repeat
if (table(.i,j.).stone and not table(.i,j.).visited) then
begin
table(.i,j.).visited:=true;
if table(.row,j.).stone then
begin
trace(.1.).icord:=row;
trace(.1.).jcord:=j;
leastamount:=table(.row,j.).unitamount;
trace(.2.).icord:=i;
trace(.2.).jcord:=j;
token:=true;
end
else
begin
token:=nextrow(i,j);
if token then
begin
laststone:=laststone+1;
trace(.laststone.).icord:=i;
trace(.laststone.).jcord:=j;
end;
end;
table(.i,j.).visited:=false;
end;
j:=j+1;
until (j>lastdestin) or token;
nextcolumn:=token;
end;
procedure nextsolution;
var step: doublerange;
double: boolean;
x,y: maxrange;
begin
double:=false;
table(.row,col.).unitamount:=leastamount;
table(.row,col.).stone:=true;
for step:=1 to laststone do
begin
leastamount:=-leastamount;
x:=trace(.step.).icord;
y:=trace(.step.).jcord;
table(.x,y.).unitamount:=table(.x,y.).unitamount+leastamount;
if (not double) and (table(.x,y.).unitamount=0) then
begin
double:=true; table(.x,y.).stone:=false
end;
end;
end;
procedure optimum;
var best: boolean;
joke: boolean;
begin
best:=false;
while not best do
begin
rowhead(.1.):=0; count:=0;
dorow(1,0);
improveindex;
if leastindex < 0 then
begin
laststone:=2;
joke:=nextrow(row,col);
nextsolution;
end
else
best:=true
end
end;
procedure losning;
var i,j: maxrange; k:integer; ch:char;
onecost,totalcost: real;
begin
writeln(clrhom);
if prt then writeln(outf,@12);
write(outf,'---------------------------- L Ø S N I N G ');
writeln(outf,'----------------------------');
writeln(outf); writeln(outf);
totalcost:=0; k:=0;
write(outf,'afsender modtager Enheder');
writeln(outf,' Udgift/enhed Udgift');
for i:=1 to lastsource do
for j:=1 to lastdestin do
begin
if table(.i,j.).stone then
begin
onecost:=table(.i,j.).unitamount*table(.i,j.).unitcost;
write(outf,i:4,' ':8,j:4,table(.i,j.).unitamount:14:0);
writeln(outf,table(.i,j.).unitcost:14:2,onecost:18:2);
totalcost:=totalcost+onecost;k:=k+1;
end;
if k=20 then
begin writeln;write(' Tast return > ');
readln(ch);k:=0;
end;
end;
writeln(outf); writeln(outf);
writeln(outf,'De samlede transport omkostninger er: ',totalcost:10:2);
writeln(outf); writeln(outf);
if extra>0 then
if extra=1 then
writeln(outf,' Vi har indført extra modtager nr ',lastdestin)
else writeln(outf,' Vi har inført extra afsender nr ',lastsource);
close(outf);
writeln; write(' Tast return > ');
readln(svar);
end;
procedure menu;
begin
repeat
writeln(clrhom);writeln;
writeln(' DET KLASSISKE TRANSPORTPROBLEM');
writeln;
writeln;
writeln(' Der kan vælges mellem følgende muligheder:');
writeln;
writeln(' 1. Kørsel af ny transport opgave.');
writeln;
writeln(' 2. Kørsel af gammel transport opgave.');
writeln;
writeln(' 3. Gentag udskrivning af løsningen.');
writeln;
writeln(' 4. Forklaring.');
writeln;
writeln(' 5. Stop kørslen.');
writeln;
write(' Anfør det ønskede nummer > ');
readln(svar); writeln;
if svar in (.'1'..'4'.) then writeln(clrhom);
case svar of
'1':begin
inputdata;
inputcost;
retdata;
gemdata;
printer;
dummy;
nordvest;
optimum;
losning;
end;
'2':begin
hentdata;
uddata;
retdata;
gemdata;
printer;
dummy;
nordvest;
optimum;
losning;
end;
'3':begin
printer;
losning;
end;
'4':forklaring;
end;
until svar='5';
end; (* menu *)
begin (* MAIN *)
menu
end.
«eof»