View \EXTERN.PAS

Source To Trade Wars 2001 the BBS Door Game

Submitted By: WEBMASTER
Rating: (Not rated) (Rate It)

PROGRAM Maintenance;

(*$C-*) (*$v-*)
(*$I COMMON.PAS*)

CONST
fs = 'TWDATA.DAT';

TYPE
users = RECORD
fa, { Game Handle }
fareal : string[41]; { Real Name }
fb,
fc,
fd,
fe,
ff,
fg,
fh,
fi,
fj,
fk,
fl,
fr,
fp,
fm,
fo,
fq,
ft,
fv : INTEGER;
newcash : real; { Converted to real }
END;

teamrec = RECORD
name : string[41]; { Team name }
captain : string[41]; { Team captain }
datemade : string[8]; { creation date }
password : string[8]; { team password }
rank : real; { -not/used- }
kills : integer; { Combat medals }
END;

VAR
smg : FILE OF smr;
pnn : STRING[41];
rteams,
tteams : teamrec;
teams : file of teamrec;
y,
a,
mo,
d,
go,
pn,
pd,
s2,
st,
g2,
prr : INTEGER;
ay,
tt,
lp,
ls,
lt1,
ll1 : INTEGER;
userf : FILE OF users;
userz,
usery,
userr,
usert : users;
e : ARRAY[1..6] OF INTEGER;
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,
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);
IF (dest=pn) THEN
thisuser.option := thisuser.option+[smw];
END;

PROCEDURE message(p,po,n,n1: INTEGER);
BEGIN
IF po < 2 THEN
ssm(p,'The Ferrengi destroyed '+cstr(n)+' of your fighters.')
ELSE
BEGIN
readin(po,usert);
IF n1=0 THEN
WITH usert DO
ssm(p,fa+' destroyed '+cstr(n)+' of your fighters.')
ELSE
WITH usert DO
ssm(p,fa+' destroyed '+cstr(n1)+' armor points and '
+cstr(n)+' of your fighters.');
END;
END;

PROCEDURE removeship(p:INTEGER);

VAR
r,b : INTEGER;
done : BOOLEAN;
BEGIN
readin(p,usery);
r := usery.ff;
IF r<>0 THEN
BEGIN
readin(lp+r,usery);
a := usery.fi;
IF a<>0 THEN
IF a=p THEN
BEGIN
readin(a,usery);
b := usery.fo;
readin(lp+r,usery);
usery.fi := b;
writeout(lp+r,usery);
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;
END;
END;

PROCEDURE rsm;

VAR
x: smr;
i: INTEGER;
BEGIN
(*$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
writeln(x.msg);
SEEK(smg,i);
x.destin := -1;
WRITE(smg,x);
END;
i := i+1;
UNTIL (i>FILESIZE(smg)-1) OR hangup;
CLOSE(smg);
END;
END;

PROCEDURE DELETE(p: INTEGER);

VAR
l: INTEGER;
BEGIN
readin(p,usert);
writeln('Terminating '+usert.fa+' ('+cstr(p)+')...');
removeship(p);
readin(p,usert);
usert.fm := 0;
usert.fr := 0;
usert.fareal := 'Maint deleted record';
usert.fo := 0;
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
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=2000);
IF NOT found THEN
BEGIN
sysoplog('*** Error - Sector path not found - from sector'
+cstr(a)+' to sector'+cstr(b));
writeln('*** 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 picksec(VAR v: INTEGER);
BEGIN
v := RANDOM(3)+1;
IF v<>1 THEN
v := RANDOM(1000)+1
ELSE
BEGIN
v := RANDOM(8)+1;
case v of
1 : v := 80;
2 : v := 81;
3 : v := 999;
4 : v := 82;
5 : v := 789;
6 : v := 86;
7 : v := 689;
8 : v := 754;
END;
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 THEN
BEGIN
usert.fv := 0;
writeout(l,usert);
END
ELSE
BEGIN
g0 := usert.fg + usert.fe;
h0 := usert.fh;
f0 := usert.fi;
j0 := usert.fj;
k0 := usert.fk;
l0 := usert.fl;
v := g0*2+h0*25+ROUND(f0*2.5)+j0*5+ROUND(k0*8.75)+ROUND(l0/20);
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); (* P is dead guy, PN is killer *)
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 THEN
BEGIN
usert.fm := -2;
writeout(l,usert);
END;
END;
END;

PROCEDURE addmsg(i:STR);
BEGIN
WRITELN(msger,i);
END;

PROCEDURE cattack(go,p,f:INTEGER);

VAR
r,k,c13,r13,v,n,pn : INTEGER;
BEGIN
IF f>g[go,1] THEN
f := g[go,1];
IF (p>1) AND (p<=lp) THEN
BEGIN
c13 := g[go,0]+lp;
readin(c13,usert);
IF (usert.fm=-1) AND (f>=1) THEN
BEGIN
readin(p,usert);
IF usert.ff=c13-lp THEN
BEGIN
r := 0;
k := 0;
REPEAT
v :=random(2);
IF v=1 THEN
r := r+1
ELSE
k := k+1;
UNTIL (r>usert.fg) OR (k>=f);
g[go,1] := g[go,1]-k;
readin(c13,usert);
usert.fl := g[go,1];
writeout(c13,usert);
IF g[go,1]<1 THEN
BEGIN
usert.fm := 0;
usert.fl := 0;
writeout(c13,usert);
g[go,0] := 0;
g[go,1] := 0;
END;
readin(p,usert);
f := usert.fg-r;
n := r;
r13 := r;
pn := -1;
message(p,pn,n,0);
IF f>0 THEN
BEGIN
readin(p,usert);
usert.fg := f;
writeout(p,usert);
END
ELSE
killed(pn,p);
readin(p,usert);
IF g[go,0]=0 THEN
begin
addmsg(usert.fa+' bravely fought off an attack by the Ferrengi!');
sysoplog(usert.fa+': lost '+cstr(k)+
', destroyed '+cstr(r13)+' Ferrengi. (Ferrengi wiped out)');
end
ELSE
IF usert.fc=-1 THEN
begin
addmsg(usert.fa+' fell prey to the Ferrengi and was destroyed!');
sysoplog(usert.fa+': lost '+cstr(k)+
', destroyed '+cstr(r13)+' (Player destroyed)');
end;
END;
END;
END;
END;

PROCEDURE movecabal(go,a,b:INTEGER);

(*35090/ MOVE GROUP CABAL (GROUP G) FROM SECTOR A TO SECTOR B (NEXT TO EACH OTHER)*)

VAR
t1,
n,p,v,k,l: INTEGER;
BEGIN
writeln('*** MoveCabal - Group ',go,' of ',g[go,1],' fighters moves from sect ',a,' to ',b);
IF (a>=1) AND (b>=1) AND (a<=ls-lp) AND (b<=ls-lp) AND (a<>b) THEN
BEGIN
n := g[go,1];
readin(a+lp,usert);
IF usert.fm<>-1 THEN
BEGIN
g[go,0] := 0;
g[go,1] := 0;
END
ELSE
BEGIN
IF usert.fl<=n THEN
BEGIN
n := usert.fl;
g[go,1] := n;
usert.fl := 0;
usert.fm := 0;
writeout(a+lp,usert);
END
ELSE
IF usert.fl>n THEN
BEGIN
usert.fl := usert.fl-n;
writeout(a+lp,usert);
END;
g[go,0] := b;
readin(b+lp,usert);
IF usert.fl=0 THEN
BEGIN
usert.fl := n;
usert.fm := -1;
writeout(b+lp,usert);
END
ELSE
BEGIN
p := usert.fm;
IF p=-1 THEN
BEGIN
usert.fl := usert.fl+n;
writeout(b+lp,usert);
END
ELSE
BEGIN
l := 0;
k := 0;
REPEAT
v := RANDOM(2)+1;
IF v=1 THEN
l := l+1
ELSE
k := k+1;
UNTIL (l>=usert.fl) OR (k>=g[go,1]);
if p>1 then begin
readin(p,userr);
message(p,-1,l,0);
end;
if p < -10 then
begin
seek(teams,abs(p)-10);
read(teams,tteams);
t1:=1;
repeat
t1:=t1+1;
readin(t1,userz);
until ((userz.fa = tteams.captain) or (t1>150));
if t1<150 then
begin
userr := userz;
addmsg('The Ferrengi attacked '+tteams.captain+'''s team!');
ssm(t1,'The Ferrengi destroyed '+cstr(l)+
' of your team''s fighters in sector '+cstr(b));
sysoplog('The Ferrengi munched '+cstr(l)+
' of team '+cstr(abs(p)-10)+'''s depl. fighters in sector '+cstr(b));
end;
end;
IF l<usert.fl THEN
BEGIN
addmsg(userr.fa+' valiantly fought off the Ferrengi!');
g[go,0] := 0;
g[go,1] := 0;
usert.fl := usert.fl-l;
writeout(b+lp,usert);
sysoplog(' Group '+cstr(go)+' --> Sector '
+cstr(b)+'('+userr.fa+'):');
sysoplog(' lost '+cstr(k)+
', dstrd '+cstr(l)+' (Ferrengi ftrs lose battle)');
END
ELSE
BEGIN
addmsg('The Ferrengi destroyed '+userr.fa+'''s fighters!');
usert.fl := n-k;
usert.fm := -1;
writeout(b+lp,usert);
n := n-k;
g[go,1] := n;
sysoplog(' Group '+cstr(go)+' --> Sector '
+cstr(b)+'('+userr.fa+'):');
sysoplog(' lost '+cstr(k)+
', dstrd '+cstr(l)+' (Player ftrs lose battle)');
END;
END;
END;
END;
END;
END;

PROCEDURE maint;

VAR
ttn,ijk,
i,p,l,m,a,l2,
e1,v,s1,r,go,
b1,g1,sc1,t1 : INTEGER;
active,
done,done1 : BOOLEAN;
x : smr;
smg2 : FILE OF smr;
BEGIN
writeln('TradeWars 2001 Daily Maintence program');
writeln('Running.....');
nl;
sysoplog(' ');
sysoplog('-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-');
sysoplog(time+' '+date+' : TW Maintence program ran');
sysoplog('-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-');

readin(1,usert);
l2 := usert.fk;
nl;
getdate;
l2 := d-l2;
FOR p:=2 TO lp DO
BEGIN
readin(p,usert);
IF usert.fb<=l2 THEN
IF (usert.fc<>0) AND (usert.fm>0) THEN
BEGIN
sysoplog(' - '+usert.fa+' deleted from game');
delete(p);
END;
END;

ASSIGN(smg2,'tradewar\twsmf2.dat');
REWRITE(smg2);
(*$I-*)
RESET(smg); (*$I+*)
IF IORESULT=0 THEN
BEGIN
i := 0;
IF i<=FILESIZE(smg)-1 THEN
BEGIN
SEEK(smg,i);
READ(smg,x);
END;
WHILE (i<FILESIZE(smg)-1) DO
BEGIN
IF x.destin<>-1 THEN
WRITE(smg2,x);
i := i+1;
SEEK(smg,i);
READ(smg,x);
END;
IF x.destin<>-1 THEN
WRITE(smg2,x);
CLOSE(smg);
END;
CLOSE(smg2);
ERASE(smg);
RENAME(smg2,'tradewar\twsmf.dat');

ASSIGN(teams,'tradewar\twteam.dat');
RESET(teams);
for ttn := 1 to 50 do
begin
active := false;
seek(teams,ttn);
read(teams,tteams);
if tteams.name <> '' then
begin
for ijk := 2 to lp do
begin
readin(ijk,userz);
if (userz.fr = ttn) and (userz.fm <> 0) then active := true;
end;
if not active then
begin
for ijk := 2 to lp do
begin
readin(ijk,userz);
if userz.fr = ttn then
begin
userz.fr :=