Shareware Overload/ShartewareOverload.cdr/games/gammon20.zip/COMMTAG.PAS

Pascal/Delphi Source File | 1991-06-19 | 17KB | 769 lines

{Common.Tag for WWIV doors on T.A.G BBS.  Turbo-Pascal 5.0
 by Joel Bergen ProVision BBS 206-353-6966

Version 1.0

Features of COMMON.TAG:

     Reads DOOR.SYS instead of CHAIN.TXT
     Does does all I/O through the FOSSIL driver.
     Outputs ANSI escape codes instead of ^C WWIV color codes.

This unit can be used to recompile WWIV doors for use by T.A.G and GAP BBS
}

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}

Uses
  Dos, Fossil, crt;

TYPE
     userrec=record
               name:string[25];
               realname:string[14];
               laston:string[10];
               linelen:byte;
               pagelen:byte;
               sl:byte;
               age:byte;
               sex:char;
               callsign:string[8];
               gold:real;
             end;
      regs=registers;

var
    usernum,baudrate:integer;
    incom,okansi,cs,so,hangup:boolean;
    timeon,timeleft:real;
    thisuser:userrec;
    rp:regs;
    ComPort:byte;
    lastkey:real;
    current_color:byte;
    stdout : text;

function cstr(i:longint):string;
var c:string;
begin
  str(i,c); cstr:=c;
end;

function timer:real;
var reg:registers;
    h,m,s,t:real;
begin
  reg.ax:=44*256;
  msdos(Dos.Registers(reg));
  h:=(reg.cx div 256);
  m:=(reg.cx mod 256);
  s:=(reg.dx div 256);
  t:=(reg.dx mod 256);
  timer:=h*3600+m*60+s+t/100;
end;

function nsl:real;
begin
  if timer<timeon then
    timeon:=timeon-24.0*3600.0;
  nsl:=timeleft-(timer-timeon);
end;

function sysop1:boolean;
begin
  sysop1:=false;
end;

function sysop:boolean;
begin
  sysop:=sysop1;
end;

procedure sl1(i:string);
begin
end;

procedure sysoplog(i:string);
begin
end;

function tch(i:string):string;
begin
  if length(i)>2 then i:=copy(i,length(i)-1,2) else
    if length(i)=1 then i:='0'+i;
  tch:=i;
end;

function time:string;
var reg:registers;
    zt:integer;
    h,m,s:string[4];
begin
  reg.ax:=$2c00; intr($21,Dos.Registers(reg));
  zt:=reg.cx shr 8;  h:=cstr(zt);
  zt:=reg.cx mod 256; str(zt,m); str(reg.dx shr 8,s);
  time:=tch(h)+':'+tch(m)+':'+tch(s);
end;

function date:string;
var reg:registers;
    m,d,y:string[4];
begin
  reg.ax:=$2a00; msdos(Dos.Registers(reg)); str(reg.cx,y); str(reg.dx mod 256,d);
  str(reg.dx shr 8,m);
  date:=tch(m)+'/'+tch(d)+'/'+tch(y);
end;

function value(I:string):integer;
var n,n1:integer;
begin
  val(i,n,n1);
  if n1<>0 then begin
    i:=copy(i,1,n1-1);
    val(i,n,n1)
  end;
  value:=n;
  if i='' then value:=0;
end;


function nam:string;
var s:string; i:integer; tf:boolean;
begin
  s:=thisuser.name;
  tf:=true;
  for i:=1 to length(s) do
    if s[i]<'A' then
      tf:=true
    else begin
      if (s[i]<='Z') and not tf then
        s[i]:=chr(ord(s[i])+32);
      tf:=false;
    end;
  nam:=s+' #'+cstr(usernum);
end;

function leapyear(yr:integer):boolean;
begin
  leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
end;

function days(mo,yr:integer):integer;
var d:integer;
begin
  d:=value(copy('312831303130313130313031',1+(mo-1)*2,2));
  if (mo=2) and leapyear(yr) then d:=d+1;
  days:=d;
end;

function daycount(mo,yr:integer):integer;
var m,t:integer;
begin
  t:=0;
  for m:=1 to (mo-1) do t:=t+days(m,yr);
  daycount:=t;
end;

function daynum(dt:string):integer;
var d,m,y,t,c:integer;
begin
  t:=0;
  m:=value(copy(dt,1,2));
  d:=value(copy(dt,4,2));
  y:=value(copy(dt,7,2))+1900;
  for c:=1985 to y-1 do
    if leapyear(c) then t:=t+366 else t:=t+365;
  t:=t+daycount(m,y)+(d-1);
  daynum:=t;
  if y<1985 then daynum:=0;
end;

function dat:string;
var ap,x,y:string; i:integer;
begin
  case daynum(date) mod 7 of
    0:x:='Tue';
    1:x:='Wed';
    2:x:='Thu';
    3:x:='Fri';
    4:x:='Sat';
    5:x:='Sun';
    6:x:='Mon';
  end;
  case value(copy(date,1,2)) of
    1:y:='Jan';
    2:y:='Feb';
    3:y:='Mar';
    4:y:='Apr';
    5:y:='May';
    6:y:='Jun';
    7:y:='Jul';
    8:y:='Aug';
    9:y:='Sep';
    10:y:='Oct';
    11:y:='Nov';
    12:y:='Dec';
  end;
  x:=x+' '+y+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
  y:=time; i:=value(copy(y,1,2));
  if i>11 then ap:='pm' else ap:='am';
  if i>12 then i:=i-12;
  if i=0 then i:=12;
  dat:=cstr(i)+copy(y,3,3)+' '+ap+'  '+x;
end;

procedure checkhangup;
begin
  if incom then
    if NOT CarrierDetect(ComPort-1) THEN Hangup := TRUE;
end;

procedure getkey
(var c:char); forward;

procedure prompt(i:string); forward;

procedure mo(c:char);
{send char out modem only, not on screen}
begin
  if incom and (not hangup) then TransmitChar(ComPort-1,c);
end;

PROCEDURE o1(c:char);
{output 1 character to screen & modem}
BEGIN
  if incom then begin
    CheckHangup;
    WriteChar(c); {write to screen}
    mo(c);        {send to modem}
  end else write(stdout,c);
END;

PROCEDURE Forec(c:INTEGER);
{This will change the foreground color of local and remote
        0 = Black        8 = Dark Grey
        1 = Blue         9 = Light Blue
        2 = Green       10 = Light Green
        3 = Cyan        11 = Light Cyan
        4 = Red         12 = Light Red
        5 = Magenta     13 = Light Magenta
        6 = Brown       14 = Yellow
        7 = Light Grey  15 = White
also modified to only change colors if different than current color}
VAR i:STRING;
BEGIN
  IF c<>Current_Color THEN BEGIN
    Current_Color := c;
    i:=#27+'[0';
    IF c>8 THEN BEGIN
      i:=i+';1';
      c:=c-8;
    END;
    CASE c OF
      0:i:=i+';30';    {black foreground}
      1:i:=i+';34';    {blue foreground}
      2:i:=i+';32';    {green     "    }
      3:i:=i+';36';    {cyan      "    }
      4:i:=i+';31';    {red       "    }
      5:i:=i+';35';    {magenta   "    }
      6:i:=i+';33';    {yellow    "    }
      7:i:=i+';37';    {white     "    }
      8:i:=i+';0';
    END;
    i:=i+'m';
    Prompt(i);
  END;
END;

Procedure ansic(c:integer);
var i:string;
    j:byte;
begin
if okansi then
  case c of
    0 : forec(7);
    1 : forec(11);
    2 : forec(14);
    3 : forec(5);
    4 : begin forec(15); prompt(#27+'[44m'); end; {white on blue}
    5 : forec(2);
    6 : begin forec(12); prompt(#27+'[5m'); end;
    7 : forec(1);
  end;
end;

procedure sdc;
var f:integer;
begin
  ansic(0);
end;

procedure pausescr;
var i:integer; cc:char;
begin
  ansic(3); prompt('[ENTER]'); ansic(0);
  repeat getkey(cc); until byte(cc)>0;
  for i:=1 to 7 do
    prompt(#8+' '+#8);
end;

procedure prompt;
var c:integer; pp:byte; cc:char;
begin
  if (not hangup) then
    for c:=1 to length(i) do begin
      if (i[c]=#10) then ansic(0);
      o1(i[c]);
    end;
end;

procedure nl;
begin
  ansic(0);
  prompt(#13+#10);
end;

procedure print(i:string);
begin
  prompt(i);
  nl;
end;

procedure prt(i:string);
begin
  ansic(2); prompt(i); ansic(0);
end;

procedure ynq(i:string);
begin
  ansic(5); prompt(i);
end;

procedure mpl(c:integer);
var n:integer; i:string;
begin
  if okansi then begin
    ansic(4);
    i:='';
    for n:=1 to c do i:=i+' ';
    prompt(i);
    prompt(#27+'['+cstr(c)+'D');
  end;
end;

procedure tleft;
var x,y:integer;
begin
  if timer<timeon then timeon:=timeon-24.0*60*60;
  if (nsl<0) then begin
    nl;
    print('Time expired.');
    hangup:=true;
  end;
  checkhangup;
end;

function empty:boolean;
begin
  rp.ax:=$0b00;
  msdos(Dos.Registers(rp));
  if (rp.ax and $00ff)=$00 then
    empty:=true
  else
    empty:=false;
end;

procedure getkey;
{wait for char, no echo, set hangup if timed out}
VAR r : REAL;
    beeped : BOOLEAN;
    SaveCh : CHAR;
BEGIN
  r := timer; beeped:=FALSE;
  REPEAT
    CheckHangup;
    IF ((timer-r) > 120.0) AND NOT beeped THEN BEGIN
      o1(#7);
      beeped:=TRUE;
    END;
    IF (timer-r) > 180.0 THEN BEGIN
      Print('Call back when you wake up.');
      Hangup:=TRUE;
      IF incom THEN begin
        setdtr(comport-1,false);
        delay(2000);
        setdtr(comport-1,true);
      end;
    END;
  UNTIL KeyPressed OR (incom and (SerialInput(comport-1) OR Hangup));
  IF KeyPressed AND NOT Hangup THEN BEGIN  {local key}
    c := ReadKey;
    IF c=#0 THEN BEGIN
      c:=ReadKey;
      CASE c OF
       {#59 : F1;}
        #63 : BEGIN {F5}
                IF incom THEN begin
                  setdtr(comport-1,false);
                  delay(2000);
                  setdtr(comport-1,true);
                end;
                Hangup := TRUE;
              END;
      END;
      c:=#0; {return a null}
    END;
  END ELSE BEGIN  {remote key}
    IF incom and (NOT Hangup) THEN c:=receivechar(comport-1);
  END;
END;

procedure cls;
begin
  prompt(#27+'[2J');
end;

procedure go(x,y:byte);
var p1,p2:string;
    outchr:byte;
begin
  x:=x mod 80;
  y:=y mod 25;
  p1:=#27+'[';
  str(y,p2);
  p1:=p1+p2+';';
  str(x,p2);
  p1:=p1+p2+'H';
  prompt(p1);
end;

Procedure Locate(x,y:byte);
{used by games like Gammon11.  Don't know why they reversed x & y...}
begin
  go(y,x);
end;

function yn:boolean;
var c:char;
begin
  if not hangup then begin
    ansic(1);
    repeat
      getkey(c);
      c:=upcase(c);
    until (c='Y') or (c='N') or (c=chr(13)) or hangup;
    if c='Y' then begin
      print('Yes');
      yn:=true;
    end else begin
      print('No');
      yn:=false;
    end;
    if hangup then yn:=false;
  end;
end;

procedure input1(var i:string; ml:integer; tf:boolean);
var cp:integer;
    c:char;
    r:real;
begin
 checkhangup;
 if not hangup then begin
  r:=timer;
  cp:=1;
  repeat
    getkey(c);
    if c=#1 then r:=timer;
    if not tf then c:=upcase(c);
    if (c>=' ') and (c<chr(127)) then
      if cp<=ml then begin
      i[cp]:=c;
      cp:=cp+1;
      prompt(c);
    end else else case ord(c) of
      8:if cp>1 then begin
               c:=chr(8);
               prompt(#8#32#8);
               cp:=cp-1;
             end;
      21,24:while cp<>1 do begin
               cp:=cp-1;
               prompt(#8#32#8);
             end;
    end;
    if (timer-r)>300.0 then hangup:=true;
  until (c=#13) or (c=#14) or hangup;
  i[0]:=chr(cp-1);
  nl;
 end;
end;

procedure input(var i:string; ml:integer);
begin
  input1(i,ml,false);
end;


procedure inputl(var i:string; ml:integer);
begin
  input1(i,ml,true);
end;

procedure onek(var c:char; ch:string);
begin
  repeat
    getkey(c);
    c:=upcase(c);
  until (pos(c,ch)>0) or hangup;
  if hangup then c:=ch[1];
  print(''+c);
end;


 procedure wkey(var abort,next:boolean);
 var cc:char;
 begin
    while not (empty or hangup or abort) do begin
      getkey(cc);
      if (cc=' ') or (cc=chr(3)) or (cc=chr(24)) or (cc=chr(11)) then
        abort:=true;
      if (cc=chr(14)) then begin abort:=true; next:=true; end;
      if (cc=chr(19)) or (cc='P') or (cc='p') then begin
        getkey(cc);
      end;
    end;
 end;

function ctim(rl:real):string;
var h,m,s:string;
begin
  s:=tch(cstr(trunc(rl-int(rl/60.0)*60.0)));
  m:=tch(cstr(trunc(int(rl/60.0)-int(rl/3600.0)*60.0)));
  h:=cstr(trunc(rl/3600.0));
  if length(h)=1 then h:='0'+h;
  ctim:=h+':'+m+':'+s;
end;

function tlef:string;
begin
  tlef:=ctim(nsl);
end;

function cstrr(rl:real; base:integer):string;
var c1,c2,c3:integer; i:string; r1,r2:real;
begin
 if rl<=0.0 then cstrr:='0' else begin
  r1:=ln(rl)/ln(1.0*base);
  r2:=exp(ln(1.0*base)*(trunc(r1)));
  i:='';
  while (r2>0.999) do begin
    c1:=trunc(rl/r2);
    i:=i+copy('0123456789ABCDEF',c1+1,1);
    rl:=rl-c1*r2;
    r2:=r2/(1.0*base);
  end;
  cstrr:=i;
 end;
end;

procedure printa1(i:string; var abort,next:boolean);
var c:integer;
begin
 checkhangup;
 if not hangup then begin
  abort:=false; next:=false; c:=1;
  if not empty then wkey(abort,next);
  while (not abort) and (c-1<length(i)) and (not hangup) do begin
    checkhangup;
    if i[c]=#3 then
      if i[c+1] in [#0..#8] then
        if okansi then
          ansic(ord(i[c+1]));
    if not empty then wkey(abort,next);
    if i[c]=#3 then
      c:=c+1
    else o1(i[c]);
    c:=c+1;
    lastkey:=timer;
  end;
 end else abort:=true;
end;

function wherex:byte;
begin
  rp.ah:=3;
  rp.bh:=0;
  intr($10,rp);
  wherex:=rp.dl+1;
end;

procedure printa(i:string; var abort,next:boolean);
var s:string; p,op,rp,rop,nca:integer; crend:boolean;
begin
  abort:=false;
  crend:=(i[length(i)]=#1) and (i[length(i)-1]<>#3);
  if crend then i:=copy(i,1,length(i)-1);
  wkey(abort,next);
  if i='' then nl;
  while (i<>'') and (not abort) and (not hangup) do begin
    rp:=0; nca:=thisuser.linelen-wherex-1; p:=0;
    while (rp<nca) and (p<length(i)) do begin
      if i[p+1]=#8 then rp:=rp-1 else
        if i[p+1]=#3 then
          p:=p+1
        else
          if (i[p+1]<>#10) then rp:=rp+1;
      p:=p+1;
    end;
    op:=p; rop:=rp;
    if (rp>=nca) and (p<length(i)) then begin
      while ((not (i[p] in [' ',#8,#10])) or (i[p-1]=#3)) and (p>1) do begin
        rp:=rp-1; p:=p-1;
      end;
      if p=1 then
        if not (i[1] in [' ',#8,#10]) then begin rp:=rp-1; p:=p-1; end;
    end;
    if abs(rop-rp)>=(thisuser.linelen div 2) then p:=op;
    s:=copy(i,1,p); delete(i,1,p);
    if (s[length(s)]=' ') then s[0]:=pred(s[0]);
    printa1(s,abort,next);
    if ((i='') and crend) or (i<>'') or abort then
      nl
    else
      printa1(' ',abort,next);
  end;
end;

procedure printacr(i:string; var abort,next:boolean);
begin
 if not abort then
  if i[length(i)]=#1 then
    printa(i,abort,next)
  else
    printa(i+#1,abort,next);
end;

procedure pfl(fn:string; var abort:boolean; cr:boolean);
var fil:text;
    i:string;
    next:boolean;
    cc:char;
begin
    if not hangup then begin
      assign(fil,fn);
      {$I-} reset(fil); {$I+}
      if ioresult<>0 then print('File not found.') else begin
        abort:=false;
        while not eof(fil) and (not abort) and (not hangup) do begin
          readln(fil,i);
          if not empty then getkey(cc) else cc:='r';
          if cc=' ' then abort:=true else print(i);
        end;
        close(fil);
      end;
      nl;nl;
    end;
end;

procedure printfile(fn:string);
var abort:boolean;
begin
  pfl(fn,abort,true);
end;

procedure iport;
var f:text;
    s:string;
    i,n:integer;
begin
  current_color:=99;
  if paramcount=0 then assign(f,'DOOR.SYS') else assign(f,paramstr(1));
  {$I-} reset(f); {$I+}
  if ioresult=0 then begin
    readln(f,s);          {COMx}
      Val(s[4],ComPort,n);
      incom:=(ComPort<>0);
    readln(f,BaudRate);           {baud}
    readln(f);                    {7 or 8}
    readln(f);                    {node number, 1-99}
    readln(f);                    {DTE baud rate}
    readln(f);                    {Y=screen on}
    readln(f);                    {Y=printer on}
    readln(f);                    {Y=Page Bell on}
    readln(f);                    {Y=Caller Alarm}
    readln(f,thisuser.name);      {User's full name}
      thisuser.realname:=Thisuser.Name;
    readln(f);                    {from city/state}
    readln(f);                    {home phone number}
    readln(f);                    {work phone number}
    readln(f);                    {user's password}
    readln(f,thisuser.sl);        {security level}
    readln(f);                    {total times on}
    readln(f,thisuser.laston);    {date last called}
    readln(f,timeleft);           {seconds left}
    readln(f);                    {minutes left}
    readln(f,s);                  {GR=Graphics, NG=No Graphics, 7E=7,E caller}
      okansi := (s='GR');
    readln(f,thisuser.pagelen);   {lines on screen (24)}
    readln(f);                    {Y=expert, N=Novice}
      thisuser.linelen:=80;
      cs:=(thisuser.sl>199);
      so:=(thisuser.sl=255);
    if incom then begin
      IF OpenFossil(ComPort-1) then
        SetBaudRate(ComPort-1,BaudRate)
      else begin
        Writeln('No Fossil!');
        close(f);
        Halt;
      end;
    end;
    close(f);
  end else begin
    writeln('Parameter file not found.');
    halt;
  end;
  hangup:=false;
  timeon:=timer;
  lastkey:=timer;
  assign(stdout,'');
  rewrite(stdout);
end;

procedure return;
begin
  {$I-} close(stdout); {$I+}
  halt;
end;

procedure topscr;
begin
end;

PROCEDURE PrintAnsiFile (fn:STRING);
{prints an ansi or text file, allowing pausing, aborting, no paging}
VAR  fil:TEXT; i:CHAR;
     abort,next:BOOLEAN;
BEGIN
  abort:=FALSE;
  IF NOT Hangup THEN BEGIN
    Assign(fil,fn);
    {$I-} Reset(fil); {$I+}
    IF IOresult=0 THEN BEGIN
      WHILE NOT EOF(fil) AND NOT Hangup AND NOT Abort DO BEGIN
        CheckHangup;
        Read(fil,i);
        o1(i);
        wkey(abort,next);
      END;
      Close(fil);
    END;
  END;
END;