PROGRAM tw2001;
{(*$C-*) (*$V-*)}
(*$I COMMON.PAS*)
CONST
fs = 'TWDATA.DAT';
p : ARRAY[1..3] OF STR =
('Ore.......','Organics..','Equipment.');
b : ARRAY[1..3] OF INTEGER =
(10,20,35);
TYPE
users = RECORD
fa : STRING[41];
FAREAL : STRING[41];
fb,fc,fd,fe,ff,fg : INTEGER;
fh,fi,fj,fk,fl,fr,fp : INTEGER;
fm,fo,fq,ft,fv : INTEGER;
credits : real;
END;
teamrec = RECORD
name : string[41];
captain : string[41];
datemade : string[8];
password : string[8];
rank : real;
kills : integer;
END;
VAR
smg : FILE OF smr;
pnn : STRING[41];
message1 : STRING[160];
y,
a,
mo,
d,
go,
pn,
pd,
s2,
st,
medalpts,
asd,
g2,
prr : INTEGER;
ay,
tt,
oath,
lp,
ls,
lt1,
ll1 : INTEGER;
userf : FILE OF users;
userz,
userr,usert : users;
e : ARRAY[1..6] OF INTEGER;
teams : file of teamrec;
rteams,
tteams : teamrec;
m,
n,
pub,
c1,
h : ARRAY[0..3] OF REAL;
s : ARRAY[0..1000,0..1] OF INTEGER;
srr : ARRAY[0..3,0..1] OF REAL;
g : ARRAY[0..9,0..1] OF INTEGER;
ended,
autop,
players,
planets,
ports,
drop,
done : BOOLEAN;
aim : STR;
msger : TEXT;
FUNCTION SGN(I:INTEGER) : INTEGER;
BEGIN
IF I>0 THEN SGN := 1
ELSE IF I<0 THEN SGN := -1
ELSE SGN := 0;
END;
PROCEDURE readin(i:INTEGER;VAR user:users);
BEGIN
SEEK(userf,i);
READ(userf,user);
END;
PROCEDURE writeout(i:INTEGER;user:users);
BEGIN
SEEK(userf,i);
WRITE(userf,user);
END;
PROCEDURE getdate;
VAR
a,code : INTEGER;
datea : STR;
BEGIN
d := daynum(date)-1094;
END;
PROCEDURE ssm(dest:INTEGER; s:STR);
VAR
x: smr;
e,cp,t: INTEGER;
u: userrec;
BEGIN
(*$I-*)
RESET(smg);(*$I+*)
IF IORESULT<>0
THEN
REWRITE(smg);
e := FILESIZE(smg);
IF e=0
THEN
cp := 0
ELSE
BEGIN
t := e-1;
SEEK(smg,t);
READ(smg,x);
WHILE (t>0) AND (x.destin=-1) DO
BEGIN
t := t-1;
SEEK(smg,t);
READ(smg,x);
END;
cp := t+1;
END;
SEEK(smg,cp);
x.msg := s;
x.destin := dest;
WRITE(smg,x);
CLOSE(smg);
END;
PROCEDURE message(p,po,n,n1: INTEGER);
BEGIN
IF (po<2)
THEN
ssm(p,'The Ferrengi destroyed '+cstr(n)+' fighters.')
ELSE
BEGIN
readin(po,usert);
if n1=0 then
WITH usert DO
ssm(p,fa+' destroyed '+cstr(n)+' fighters.')
ELSE
WITH usert DO
ssm(p,fa+' destroyed '+cstr(n1)+' shield points and '
+cstr(n)+' of your fighters.');
END;
END;
PROCEDURE removeship(p:INTEGER);
VAR
r,b : INTEGER;
done : BOOLEAN;
BEGIN
readin(p,usert);
r := usert.ff;
IF r<>0
THEN
BEGIN
readin(lp+r,usert);
a := usert.fi;
IF a<>0
THEN
IF a=p
THEN
BEGIN
readin(a,usert);
b := usert.fo;
readin(lp+r,usert);
usert.fi := b;
writeout(lp+r,usert);
END
ELSE
BEGIN
done := FALSE;
readin(a,usert);
REPEAT
IF usert.fo = p
THEN
BEGIN
b := a;
done := TRUE;
END;
a := usert.fo;
readin(a,usert);
UNTIL done;
a := usert.fo;
readin(b,usert);
usert.fo := a;
writeout(b,usert);
END;
readin(pn,userr);
END;
END;
PROCEDURE rsm;
VAR
x: smr;
i: INTEGER;
NOTHING : BOOLEAN;
BEGIN
nothing := TRUE;
(*$I-*)
RESET(smg); (*$I+*)
IF IORESULT=0
THEN
BEGIN
i := 0;
REPEAT
IF i<=FILESIZE(smg)-1
THEN
BEGIN
SEEK(smg,i);
READ(smg,x);
END;
WHILE (i<FILESIZE(smg)-1) AND (x.destin<>pn) DO
BEGIN
i := i+1;
SEEK(smg,i);
READ(smg,x);
END;
IF (x.destin=pn) AND (i<=FILESIZE(smg)-1)
THEN
BEGIN
print(x.msg);
SEEK(smg,i);
x.destin := -1;
WRITE(smg,x);
nothing := FALSE;
END;
i := i+1;
UNTIL (i>FILESIZE(smg)-1) OR hangup;
CLOSE(smg);
END;
if nothing then print('Nothing');
END;
PROCEDURE delplr(p: INTEGER);
VAR
l: INTEGER;
BEGIN
readin(p,usert);
print('Terminating '+usert.fa+' ('+cstr(p)+')...');
removeship(p);
readin(p,usert);
usert.fm := 0;
usert.fareal := 'Not used';
writeout(p,usert);
FOR l:=lp+1 TO ls DO
BEGIN
readin(l,usert);
IF usert.fm=p
THEN
BEGIN
usert.fm := -2;
writeout(l,usert);
END;
END;
pn := p;
rsm;
FOR l:=2 TO lp DO
BEGIN
readin(l,usert);
IF usert.fc=p
THEN
BEGIN
usert.fc := -98;
writeout(l,usert);
END;
END;
END;
PROCEDURE shortest(a,b: INTEGER);
VAR
n,c,l,m : INTEGER;
found : BOOLEAN;
BEGIN
if b>1000 then b:= 1000;
n := 1;
c := b;
IF a=b
THEN
BEGIN
s[0,0] := a;
s[0,1] := 0;
s[a,1] := 0;
END
ELSE
BEGIN
FOR l:=1 TO 1000 DO
FOR m:=0 TO 1 DO
s[l,m] := 0;
s[a,1] := 1;
found := FALSE;
REPEAT
l := 1;
REPEAT
IF s[l,1]=n
THEN
BEGIN
readin(l+lp,usert);
e[1] := usert.fb;
e[2] := usert.fc;
e[3] := usert.fd;
e[4] := usert.fe;
e[5] := usert.ff;
e[6] := usert.fg;
FOR m:=1 TO 6 DO
IF e[m]<>0
THEN
IF s[e[m],1]=0
THEN
BEGIN
s[e[m],1] := n+1;
s[e[m],0] := l;
IF e[m]=b
THEN
found := TRUE;
END;
END;
l := l+1;
UNTIL found OR (l>1000);
IF NOT found
THEN
n := n+1;
UNTIL found OR (n>=60);
IF NOT found
THEN
BEGIN
sysoplog('*** Error - Sector path not found - from sector'
+cstr(a)+' to sector'+cstr(b));
print('*** Error - Sector path not found - from sector'+cstr(a)+
' to sector'+cstr(b));
s[a,1] := 0;
ended := TRUE;
END
ELSE
REPEAT
s[s[c,0],1] := c;
c := s[c,0];
IF s[c,0]=0
THEN
s[b,1] := 0;
UNTIL s[c,0]=0;
END;
END;
PROCEDURE rank(VAR p: INTEGER);
VAR
l,g0,h0,f0,n,o,j0,k0,l0,v,c : INTEGER;
done : BOOLEAN;
BEGIN
FOR l:=2 TO lp DO
BEGIN
readin(l,usert);
IF usert.fm=0
THEN
BEGIN
usert.fv := -1;
writeout(l,usert);
END
ELSE
IF ((usert.fc<>0) AND (usert.fc<>-75)) OR (pos('THE CABAL',usert.fa)>0) OR (pos('THE FERRENGI',usert.fa)>0)
THEN
BEGIN
usert.fv := 0;
writeout(l,usert);
END
ELSE
BEGIN
g0 := usert.fg;
h0 := usert.fh;
f0 := usert.fi;
j0 := usert.fj;
k0 := usert.fk;
v := g0*10+h0*50+ROUND(f0*2.5)+j0*5+ROUND(k0*8.75);
usert.fv := v;
writeout(l,usert);
END;
END;
p := 0;
FOR l:=2 TO lp DO
BEGIN
readin(l,usert);
v := usert.fv;
IF v<>-1
THEN
BEGIN
n := p;
o := 0;
done := FALSE;
IF p=0
THEN
BEGIN
p := l;
usert.ft := -1;
writeout(l,usert);
END
ELSE
REPEAT
readin(n,usert);
IF (v>usert.fv) AND (o=0)
THEN
BEGIN
readin(l,usert);
usert.ft := p;
writeout(l,usert);
p := l;
done := TRUE;
END
ELSE
IF v>usert.fv
THEN
BEGIN
readin(o,usert);
c := usert.ft;
usert.ft := l;
writeout(o,usert);
readin(l,usert);
usert.ft := c;
writeout(l,usert);
done := TRUE;
END
ELSE
IF usert.ft=-1
THEN
BEGIN
readin(n,usert);
usert.ft := l;
writeout(n,usert);
readin(l,usert);
usert.ft := -1;
writeout(l,usert);
done := TRUE;
END
ELSE
BEGIN
o := n;
n := usert.ft;
END;
UNTIL done;
END;
END;
END;
PROCEDURE killed(pn,p: INTEGER);
VAR
l : INTEGER;
BEGIN
removeship(p);
readin(p,usert);
usert.fc := pn;
usert.ff := 0;
writeout(p,usert);
FOR l:=lp+1 TO ls DO
BEGIN
readin(l,usert);
IF (usert.fm=p) AND (random(2)=0)
THEN
BEGIN
usert.fm := -2;
writeout(l,usert);
END;
END;
END;
PROCEDURE mmkey(VAR i:STR);
VAR
c: CHAR;
BEGIN
REPEAT
REPEAT
ansic(3);
getkey(c);
skey(c);
UNTIL (((c>=' ') AND (c<CHR(127))) OR (c=CHR(13))) OR hangup;
c := UPCASE(c);
write(c);
thisline := thisline+c;
IF (c='/') OR (c='1')
THEN
BEGIN
i := c;
REPEAT
getkey(c);
skey(c);
UNTIL ((c>=' ')AND(c<=CHR(127))) OR (c=CHR(13)) OR (c=CHR(8)) OR
hangup;
c := UPCASE(c);
IF c<>CHR(13)
THEN
BEGIN
write(c);
thisline := thisline+c;
END;
IF (c=CHR(8)) OR (c=CHR(127))
THEN
prompt(' '+c);
IF c='/'
THEN
INPUT(i,20)
ELSE
IF c<>CHR(13)
THEN
i := i+c;
END
ELSE
i := c;
UNTIL (c<>CHR(8)) AND (c<>CHR(127)) OR hangup;
nl;
END;
PROCEDURE addmsg(i:STR);
BEGIN
WRITELN(msger,i);
END;
PROCEDURE readmsg;
BEGIN
print('The following happened to your ship since your last time on:');
rsm;
END;
PROCEDURE addship(p:INTEGER);
VAR
r,b : INTEGER;
done : BOOLEAN;
BEGIN
r := userr.ff;
IF r<>0
THEN
BEGIN
readin(lp+r,usert);
b := usert.fi;
usert.fi := p;
writeout(lp+r,usert);
userr.fo := b;
writeout(pn,userr);
END;
END;
PROCEDURE warped;
VAR
lee,l : INTEGER;
BEGIN
prompt('Warp Lanes lead to: ');
l := 0;
repeat
l := l+1;
lee := l+1;
until e[l]<>0;
prompt(cstr(e[l]));
FOR l:=lee TO 6 DO
IF e[l]<>0 THEN
prompt(','+cstr(e[l]));
nl;
END;
PROCEDURE showroom;
VAR
l,lee : INTEGER;
st4 : str;
temy : string[4];
tname : str;
BEGIN
prr := userr.ff;
s2 := prr+lp;
nl;
readin(s2,usert);
ansic(3);
if usert.fa<>'' then st4:=usert.fa else st4:='deep space';
print('Sector: '+cstr(prr)+' ('+st4+')');
st := usert.fh;
IF st<>0
THEN
BEGIN
readin(st+ls,usert);
if ports then drop := TRUE;
ansic(4);
print('Ports: '+usert.fa+', class '+cstr(usert.fb));
END
ELSE
BEGIN
ansic(4);
print('Ports: None');
END;
readin(s2,usert);
a := usert.fo;
IF a<>0
THEN
BEGIN
readin(a+lt1,usert);
if planets then drop := TRUE;
ansic(5);
print('Planet: '+usert.fa);
readin(s2,usert);
END;
g2 := 0;
prompt('Other Ships: ');
ansic(6);
a := usert.fi;
IF a=0
THEN
print('None')
ELSE
BEGIN
REPEAT
readin(a,usert);
IF a<>pn
THEN
BEGIN
if usert.fr <> 0 then temy := '['+cstr(usert.fr)+']'
else temy := '';
if players then drop := TRUE;
nl;
prompt(' '+usert.fa+' '+temy+', with '+cstr(usert.fg)+' fighters, in a');
if (usert.fh<20) then prompt('n incredibly');
if (usert.fh<35) then prompt(' small');
if (usert.fh>50) AND (usert.fh<65) then prompt(' large');
if (usert.fh>64) then prompt('n enormous');
prompt(' merchant ');
if (usert.fh<75) then prompt('ship') else prompt('Super Cruiser');
g2 := 1;
END;
a := usert.fo;
UNTIL a=0;
IF g2=0
THEN
print('None')
ELSE
nl;
ansic(1);
END;
readin(s2,usert);
prompt('Fighters in sector: ');
ansic(7);
if usert.fl=0 then print('None')
ELSE
BEGIN
aim := cstr(usert.fl);
IF (usert.fm=-2) then print(aim+' (Rogue Mercenaries)')
ELSE
if (usert.fm=-75) then print(aim+' (Space Pirates)')
ELSE
IF (usert.fm=-1) then print(aim+' (belong to The Ferrengi)')
ELSE
IF usert.fm=pn then print(aim+' (yours)')
ELSE
IF (usert.fm < (-10)) AND (usert.fm > (-61)) then
begin
seek(teams,abs(usert.fm)-10);
read(teams,tteams);
if ((rteams.name = tteams.name) and (userr.fr<>0)) then
print(aim+' (belong to your team)')
ELSE print(aim+' (belong to team#'+cstr(abs(usert.fm)-10)+', '+tteams.name+')');
end
ELSE
BEGIN
readin(usert.fm,usert);
print(aim+' (belong to '+usert.fa+')');
readin(s2,usert);
END;
END;
warped;
END;
PROCEDURE destroyed;
BEGIN
print('Your ship has been destroyed!');
nl;
print('You will start over tomorrow with a new ship.');
print('It is better to practice dying than to die unprepared!');
killed(pn,pn);
ended := TRUE;
done := TRUE;
END;
PROCEDURE info(pn:INTEGER);
VAR
a: REAL;
b,c : INTEGER;
temy : string[12];
tname : str;
BEGIN
readin(pn,usert);
nl;
if usert.fr <> 0 then
begin
temy := ' Team #'+cstr(usert.fr)+', ';
tname := rteams.name;
end
else
begin
temy := '';
tname := '';
end;
ansic(7);
print('Name: '+usert.fa+temy+tname);
ansic(2);
print('Sector: '+cstr(usert.ff)+' Turns left: '+cstr(usert.fd));
ansic(3);
print('Fighters: '+cstr(usert.fg)+' Shield points: '+cstr(usert.fe));
ansic(4);
print('Cargo Holds: '+cstr(usert.fh)+' Empty: '+cstr(usert.fh-usert.fi-usert.fj-usert.fk));
ansic(3);
print(' Ore: '+cstr(usert.fi)+' Org: '+cstr(usert.fj)+' Eqp: '+cstr(usert.fk));
ansic(2);
print('Credits: '+cstrr(usert.credits,10));
ansic(1);
nl;
END;
PROCEDURE retreat;
VAR
lr : INTEGER;
BEGIN
ansic(8);
print('<Retreat>');
ansic(1);
lr := userr.fq;
WHILE (lr=0) OR (lr=prr) DO
lr := e[RANDOM(6)+1];
IF userr.fg >=1
THEN
BEGIN
userr.fg := userr.fg-1;
writeout(pn,userr);
print('Your fighters make a valiant attempt to stall the oncoming horde.');
print('You have '+cstr(userr.fg)+' fighter(s) left.');
removeship(pn);
userr.ff := lr;
userr.fq := prr;
writeout(pn,userr);
addship(pn);
lr := a;
done := TRUE;
END
ELSE
IF userr.fe>4 then
begin
ansic(7);
print('The oncoming horde is fast & powerful, but your ship armor held...');
ansic(8);
print('...this time...');
removeship(pn);
userr.fe := userr.fe-5;
userr.ff := lr;
userr.fq := prr;
writeout(pn,userr);
addship(pn);
lr := a;
done := TRUE;
END
ELSE
IF RANDOM(2)+1=1
THEN
BEGIN
ansic(7);
&
