PROGRAM twedit;
(*$C-*) (*$v-*)
(*$I COMMON.PAS*)
CONST
fs = 'tradewar\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
sm2,
smg : FILE OF smr;
rteams,
tteams : teamrec;
lmd : integer;
pnn : STRING[41];
y,a,mo,d,go,pn,pd,s2,st,g2,prr : INTEGER;
ay,tt,lp,ls,lt1,ll1 : INTEGER;
userf : FILE OF users;
teams : FILE OF teamrec;
userz,
userr,usert : users;
e : ARRAY[1..6] OF INTEGER;
m,n,pub,c1,h : ARRAY[0..3] OF REAL;
s : ARRAY[0..200,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;
procedure Mmkey(var i:str);
var c:char;
begin
repeat
repeat
getkey(c);
until (((c>=' ') and (c<chr(127))) or (c=chr(13))) or hangup;
c:=upcase(c);
outkey(c);
thisline:=thisline+c;
if (c='/') or (c='1') then begin
i:=c;
repeat
getkey(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 outkey(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;
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;
(*34110 REM **/ REMOVE SHIP P FROM PERSON-IN-SECTOR CHAIN /**)
PROCEDURE removeship(p:INTEGER);
VAR
r,b : INTEGER;
done : BOOLEAN;
BEGIN
readin(p,usert);
r := usert.ff;
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;
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 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;
(* 34230 REM **/ DELETE PLAYER P FROM GAME /**)
PROCEDURE DELETE(p: INTEGER);
VAR
l: INTEGER;
BEGIN
readin(p,usert);
print('Deleting '+usert.fa+'...');
removeship(p);
readin(p,usert);
usert.fm := 0;
usert.fr := 0;
usert.fareal := 'Unused Player Record';
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;
(* 7500 REM **/ FIND SHORTEST ROUTE FROM A TO B IN S(200,1) /**)
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;
(*2500 RANK PLAYERS WITH FT$ AND FV$. P = STARTING PERSON, 0=NO PLAYERS *)
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;
h0 := usert.fh;
f0 := usert.fi;
j0 := usert.fj;
k0 := usert.fk;
l0 := trunc(usert.credits);
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;
FOR l:=lp+1 TO ls DO
BEGIN
readin(l,usert);
IF (usert.fl<>0) AND (usert.fm>=2)
THEN
BEGIN
a := usert.fl;
p := usert.fm;
readin(p,usert);
usert.fv := usert.fv+a*25;
writeout(p,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 addship(p:INTEGER);
(* 7000 **/ ADD SHIP P PERSON-IN-SECTOR CHAIN /**)
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 init;
VAR
l : INTEGER;
done : BOOLEAN;
BEGIN
ASSIGN(smg,'tradewar\TWSMF.DAT');
ended := FALSE;
ASSIGN(userf,'tradewar\TWDATA.DAT');
RESET(userf);
readin(1,userr);
WITH userr DO
BEGIN
ay := fc;
tt := fd;
lp := fe;
ls := ff;
lt1 := fg;
lmd := fl;
ll1 := fo;
END;
getdate;
END;
PROCEDURE helpit;
BEGIN
nl;
print('<TWEditor Commands>');
nl;
print(' <M> Run TWs Maintenance');
print(' <C> Cabal Display');
print(' <G> General info editor');
print(' <S> Sector editor');
print(' <T> Planet Display');
print(' <U> User editor');
print(' <Q> Quit back to BBS');
END;
FUNCTION addblank(b:STR;l:INTEGER): STR;
BEGIN
WHILE LENGTH(b)< l DO
b := ' '+b;
addblank := b;
END;
PROCEDURE getuser(VAR p:INTEGER; a:STR);
(*19000 GET P, A USER NUMBER FROM A$, A GIVEN AN NAME OR NUMBER. P=0 = NONE*)
VAR
found : BOOLEAN;
BEGIN
found := FALSE;
p := 2;
IF a='' THEN
p := 0
ELSE
IF value(a) <> 0 THEN
p := value(a)
ELSE
BEGIN
REPEAT
readin(p,usert);
IF usert.fareal = a THEN
found := TRUE;
p := p+1;
UNTIL (p>lp) OR found;
p := p-1;
IF NOT found THEN
BEGIN
print('Not found.');
p := 0;
END;
END;
END;
PROCEDURE uedit;
VAR
ir : real;
i : STR;
p,e : INTEGER;
BEGIN
nl;
prompt('User Name or Number: ');
INPUT(i,41);
IF (i='')
THEN done := TRUE;
getuser(p,i);
pn := p;
IF p<>0
THEN
IF (pn<2) OR (pn>lp)
THEN
BEGIN
print('Invalid player name or number.');
END
ELSE
BEGIN
cls;
readin(pn,usert);
print('Complete record storage for player number: '+cstr(pn));
nl;
prompt('<A> Alias: ');
IF usert.fm=0
THEN
print('<Player record not used>')
ELSE
print(usert.fa+' (#'+cstr(pn)+')');
prompt('<R> Real Name: ');
print(usert.fareal);
prompt('<B> Last day on: ');
getdate;
e := usert.fb;
d := d-e;
IF d=0
THEN
print(' today')
ELSE
IF d>0
THEN
print(cstr(d)+' days ago')
ELSE
print(' Will be allowed on in '+cstr(-d)+' days');
a := usert.fc;
prompt('<C> Killed by: ');
IF a=0
THEN
print('<No one>')
ELSE
IF a=-99
THEN
BEGIN
print('<To be initialized>') ;
a := 0;
END
ELSE
IF a=-98
THEN
BEGIN
print('<A person who has been deleted>') ;
a := 0;
END;
IF a<>0 THEN
IF a=-1 THEN
print('<Romulans>')
ELSE
IF a=-2 THEN
print('<Rogue fighters>')
ELSE
IF (a<2) OR (a>lp) THEN
print('Unknown value: '+cstr(a))
ELSE
BEGIN
readin(a,userr);
print(userr.fa+' (#'+cstr(a)+')');
END;
print('<D> Turns left: '+cstr(usert.fd));
print('<E> Ship Armor: '+cstr(usert.fe));
print('<F> K3-A Fighters: '+cstr(usert.fg));
print('<G> Total cargo holds: '+cstr(usert.fh));
print(' <H> Ore: '+cstr(usert.fi)+' <I> Org: '+cstr(usert.fj)+
' <J> Eqp: '+cstr(usert.fk));
print('<K> Credits: '+cstrr(usert.credits,10));
print('<L> Last sector in: '+cstr(usert.fq));
print('<M> Location: sector '+cstr(usert.ff));
print('<O> Next Ship-in-sector chain value: '+cstr(usert.fo));
print('??? USERT.FP: '+cstr(usert.fp));
print('<T> Team number: '+cstr(usert.fr));
print('<Q> Return to Main Menu ');
print('<!> Delete player ');
print('<?> Print Command List ');
nl;
prompt('Command? ');
INPUT(i,1);
IF i=''
THEN
BEGIN
END;
IF i='?'
THEN
BEGIN
END;
IF i='A'
THEN
BEGIN
nl;
prompt('New Alias? ');
INPUTl(i,41);
usert.fa := i;
usert.fm := LENGTH(usert.fa);
writeout(pn,usert);
END;
IF i='R'
THEN
BEGIN
nl;
prompt('New Real name? ');
INPUT(i,41);
usert.fareal := i;
writeout(pn,usert);
END;
IF i='B'
THEN
BEGIN
nl;
prompt('Last Day On? ');
INPUT(i,3);
a := value(i);
getdate;
usert.fb := d-a;
writeout(pn,usert);
END;
IF i='C'
THEN
BEGIN
nl;
prompt('Killed by? (-98 killer deleted, -99 TBInit) ');
INPUT(i,3);
a := value(i);
usert.fc := a;
writeout(pn,usert);
END;
IF i='D'
THEN
BEGIN
nl;
prompt('Turns Left? ');
INPUT(i,3);
a := value(i);
usert.fd := a;
writeout(pn,usert);
END;
IF i='E' THEN
begin
nl;
prompt('Ship armor? ');
input(i,3);
a := value(i);
if a > 200 then
print('Ship structure will not support more than 200.')
else
usert.fe := a;
writeout(pn,usert);
END;
IF i='F' THEN
BEGIN
nl;
prompt('K3-A Fighters on board? ');
INPUT(i,4);
a := value(i);
usert.fg := a;
writeout(pn,usert);
END;
IF i='G' THEN
