unit DDPlus;
{$V-,F+}

interface
uses dos, crt, comio, ddscott, ddansi2, ddovr, ddovr2;
type
 CharOriginType=(localchar,remotechar);
 strptr=^string;
const
 version= 'Version 7.10  ; 05-01-95';

 progname: string[60] = 'Another DDPlus 7.0 Door Game';
 graphics_codes: array[1..5] of string[4] = ('','.ASC','.ANS','.MUS','.ANS');
 { You will have to make up your mind to have item #5 .ANS or .RIP.  You may }
 { find that displaying a ripfile is more effectively done if shown some     }
 { other day.                                                                }

 ack=#6;
 nak=#21;
 sot=#1;
var
 lockbaud: longint;                 {lock baud rate                          }
 com1,com2,com3,com4 : byte;        { temporary non-std comports             }
 port1,port2,port3,port4:word;
 irq1,irq2,irq3,irq4 : byte;
 com_port: byte;                    {from DROP FILE: com port                }
 fossilIO,DigiIO: boolean;          {from .CTL file: fossil, digiboard i/o   }
 mintime: byte;                     {Minimum time left before user kicked off}
 notime: string;                    {Out of time filename                    }
 macro,macro_str: string;           {Used in the macro routines              }
 node_num: byte;                    {Node number                             }
 time_credit: integer;              {Time credit +/- (arrow keys)            }
 CharOrigin: CharOrigInType;        {Where character came from               }
 fouled_up: char;                   {Internal use                            }
 localcol: boolean;                 {From .CTL file: Local color enabled     }
 ansion: boolean;                   {Process ANSI locally                    }
 time_check: boolean;               {Check time left - halt if < mintime     }
 moreok : boolean;                  {display <more> prompt?                  }
 curlinenum: integer;               {current line num - used by <more>       }
 stacked: string;                   {used internally - stacked commands      }
 F1toggle: byte;                    {Show Help or Status Line                }
 inchat  : byte;                    {Already inchat don't do this again      }
 chatdone : boolean;                {has there been a chat?                  }
 current_foreground: byte;          {current foreground color                }
 current_background: byte;          {current background color                }
 color_chg: boolean;                {send ANSI color change sequences?       }
 default_fore: byte;                {default foreground color                }
 default_back: byte;                {default background color                }
 cdropped,tdropped: boolean;        {carrier dropped? timedropped            }
 bbs_time_left: integer;            {from DROP FILE: time left               }
 bbs_software: byte;                {from .CTL file: bbs type                }
 baud_rate: longint;                {from DROP FILE: baud rate               }
 statfore,statback: byte;           {status line foreground                  }
 statline: boolean;                 {status line background                  }
 graphics: byte;                    {from DROP FILE: graphics code           }
 local: boolean;                    {from DROP FILE: local mode              }
 user_number: word;           {from DROP FILE: user's access level     }
 user_first_name: string[30];       {from DROP FILE: user's first name       }
 user_last_name: string[30];        {from DROP FILE: user's last name        }
 sysop_first_name: string[30];      {from .CTL file: sysop's first name      }
 sysop_last_name: string[30];       {from .CTL file: sysop's last name       }
 board_name: string[70];            {from .CTL file: board name              }
 Pause_Code : string;               { Rip PAUSE CODE OF YOUR BBS             }
 st_hr, st_mn, st_sc,save_sc: word; {used by timer calculations              }
 color1: boolean;                   {from .CTL file: color1 mode             }
 EMSOK : boolean;                   {/ESM use esm memory                     }
 NetOK : boolean;                   {A Dos only network is present           }
 NoLocal : boolean;                 { Local echo turned off (statback)       }
 stackon: boolean;                  {process stacked commands?               }
 badchar: string;                   {internal use                            }
 maxtime: word;                     {from .CTL file: maximum time in door    }
 user_access_level: word;
 numlines: byte;                    {from .CTL file: number of lines/screen  }
 oldtextmode: word;                 {original text mode                      }
 GoRip      : byte;                 { enables force RIP }
 lastsetfore: byte;                 {last set_foreground color               }
 setforecheck: boolean;             {check repetetive set_foreground calls?  }
 dropfilepath: string;              {from parm list                          }
 cc          : integer;             { read cycle counter                     }

 soutput: text;                     {Simultanious output file                }

 proc_call_ptr: pointer;            {used internally                         }
 nodirect: boolean;

Procedure DV_Aware_On;
Procedure DV_Pause;
Procedure Win_Pause;
Procedure ReleaseTimeSlice;
procedure close_async_port;
procedure Open_async_port;
function  skeypressed: boolean;
Procedure Clear_Region(x,a,b:byte);
procedure sendtext(s: string);
procedure sgoto_xy(x,y: integer);
procedure sclrscr;
procedure sclreol;
procedure swrite(s: string);
procedure swritec(ch: char);
procedure swriteln(s: string);
Procedure swritexy(x,y:integer;s:string);
Procedure Propeller(v:byte);
procedure sread_char(var ch: char);
procedure sread(var s: string);
procedure sread_num(var n: integer);
procedure sread_num_byte(var b: byte);
procedure sread_num_word(var n: word);
procedure sread_num_longint(var n: longint);
Procedure speedread(var ch : char);
function time_left: integer;
procedure set_foreground(f: byte);
procedure set_background(b: byte);
procedure set_color(f,b: byte);
procedure prompt(var s: string; le: integer; pc: boolean);
Procedure elapsed(time1_hour, time1_min, time1_sec, time2_hour, time2_min,
                  time2_sec: longint; var elap_hour, elap_min, elap_sec: word);
procedure get_stacked(var s: string);
procedure sread_char_filtered(var ch: char);
procedure display_status;
Procedure Displayfile(filen: string);
Procedure SelectAnsi(chflag :char;filenm: string);
procedure DDAssignSoutput(var f: text);
procedure InitDoorDriver(ConfigFileName: string);
function Time_used: integer;

Implementation
{$L DVAWARE.OBJ}

Procedure DV_Aware_On;       External;
Procedure DV_Pause;          External;

var
 buffered: boolean;
 exitsave: pointer;
 tcolor,bcolor: integer;
 firsttime: boolean;


procedure Dos_Sleep;
var
 Regs : Registers;
begin
 with Regs do
   Intr($28,Regs);
end;
{ This releases the virtual machine time slice for MSwindows, Dos 5.0, OS/2 }

procedure Win_Pause;
var
 Regs : Registers;
begin
 with Regs do
 begin
   Ax := $1680;
   Intr($2F,Regs);
 end;
end;

Procedure ReleaseTimeSlice;
begin
  Case Tasker of
    1     : DV_Pause;
    2,4,5 : Win_Pause;
    3     : begin
             Win_Pause;
             Dos_Sleep;        { OS/2 likes this/ it don't hurt }
            end;
  else
    Dos_Sleep;
  end;
end;

Procedure Clear_Region(x,a,b:byte);
var
  i : byte;
begin
  for i := a to b do
    begin
      SGoto_XY(x,i);
      Sclreol;
    end;
end;

Procedure Chat_Eof(flag:byte);
begin
  If wherey =24 then
    begin
      Clear_Region(1,19,21);
      SGoto_XY(1,19);
      Swrite('?');
    end
  else
  if flag=1 then
    swriteln('');
  If wherey=22 then
    begin
      Clear_Region(1,22,24);
      Sgoto_XY(1,22);
    end;
end;

{ This is the old continous rolling chat                           }
{
procedure forced_chat;
var
 cx,cy:byte;
 ch: char;
 a: integer;
 old_origin: charorigintype;
 word: string;
 lastspace: integer;
begin;
 swriteln('');
 set_foreground(lightred);
 swriteln('Chat mode enabled. ESC exits.');
 set_foreground(lightblue);
 old_origin:=localchar;
 lastspace:=0;
 word:='';
 repeat;
  sread_char(ch);
  if charorigin<>old_origin then if charorigin=localchar then set_foreground(lightblue) else set_foreground(yellow);
  old_origin:=charorigin;
  swrite(ch);
  if ch=#8 then begin;
   swrite(' '+#8);
   if length(word)>0 then delete(word,1,1);
  end;
  if ch=#13 then begin;
   swrite(#10);
   lastspace:=0;
   word:='';
  end;
  if (ch<>' ') and (ch<>#8) and (ch<>#13) then word:=word+ch;
  if ch=' ' then begin;
   lastspace:=wherex;
   word:='';
  end;
  if wherex>75 then begin;
   if lastspace=0 then begin;
    swriteln('');
   end else begin;
    while wherex>lastspace do swrite(#8+' '+#8);
    swriteln('');
    swrite(word);
   end;
  end;
 until ch=#27;
 set_foreground(default_fore);
end;
}
{ This is the new formated chat that uses lines 19-24 for a chat   }
{ window that rolls from 19-24 and back again.                     }

{ Remember to check for #3 when this returns so you can refresh the }
{ area this has colored black.                                      }
procedure forced_chat;
var
  i,x,y,cx,cy,oldy:byte;
  ch: char;
  a: integer;
  old_origin: charorigintype;
  word: string;
  lastspace: integer;

begin;
  SGoto_XY(1,19);
  Set_Color(0,6);
  swrite(' The SYSOP wants to chat with you.       [ESC] to exit.');
  Sclreol;
  Set_Color(7,0);
  Clear_Region(1,20,24);
  SGoto_XY(1,20);
  Swrite('?');
  set_foreground(11);
  old_origin:=localchar;
  lastspace:=0;
  word:='';

  repeat;
  sread_char(ch);
  if charorigin<>old_origin then
    if charorigin=localchar then
      set_foreground(11)
    else
      set_foreground(14);
  old_origin:=charorigin;
  swrite(ch);
  if ch=#8 then
    begin
      swrite(' '+#8);
      if length(word)>0 then
        delete(word,1,1);
    end;

  if ch=#13 then
   begin
     if wherey >23 then
       Chat_Eof(0)
     else
      begin
       swrite(#10);
        if wherey =22 then
          Chat_Eof(0);
       swrite('?');
      end;
     lastspace:=0;
     word:='';
   end;

  if (ch<>' ') and (ch<>#8) and (ch<>#13) then
    word:=word+ch;
  if ch=' ' then
    begin
     lastspace:=wherex;
     word:='';
    end;

  if wherex>75 then
    begin
     if lastspace=0 then
        Chat_Eof(1)
     else
       begin
         while wherex>lastspace do swrite(#8+' '+#8);
         Chat_Eof(1);
         swrite(word);
       end;
    end;
  until ch=#27;
  Set_Color(7,0);
  Clear_Region(1,19,24);
end;

Procedure DropMessage;
begin;
   writeln;
   writeln('Carrier Dropped, returning to BBS.');
   cdropped:=true;
   halt;
end;

procedure BlankScreenMessage;
begin
  gotoxy (trunc((80-length(progname))/2),10);
  write(progname);
  gotoxy (26,12);
  write('Local screen mode turned off.');
  gotoxy (1,1);
end;

Procedure HosedMessage;
begin
  Swriteln('');
  Swriteln('');
  Set_Color(15,0);
  Swrite('The SYSOP has terminated the game and is returning you to the BBS!');
  ReleaseTimeSlice;
  delay(500);
  ReleaseTimeSlice;
end;

procedure textcolor(i: byte);
begin;
 if localcol then crt.textcolor(i);
 tcolor:=i;
end;

procedure textbackground(i: byte);
begin;
 if localcol then crt.textbackground(i);
 bcolor:=i;
end;

procedure elapsed(time1_hour, time1_min, time1_sec, time2_hour, time2_min,
                  time2_sec: longint; var elap_hour, elap_min, elap_sec: word);
var
 a,b,c: longint;
begin;
 if time1_hour<time2_hour then time1_hour:=time1_hour+24;
 a:=(time1_hour*3600)+(time1_min*60)+time1_sec;
 b:=(time2_hour*3600)+(time2_min*60)+time2_sec;
 c:=a-b;
 if c>=3600 then elap_hour:=c div 3600 else elap_hour:=0;
 c:=c-((c div 3600)*3600);
 if c>=60 then elap_min:=c div 60 else elap_min:=0;
 c:=c-((c div 60)*60);
 elap_sec:=c;
end;

function time_left: integer;
var
 hour, minute, second, sec100: word;
 el_hr, el_mn, el_sc: word;
begin;
 gettime(hour, minute, second, sec100);
 elapsed(hour, minute, second, st_hr, st_mn, st_sc, el_hr, el_mn, el_sc);
 time_left:=time_credit+(bbs_time_left-((el_hr*60)+el_mn));
end;

function time_used: integer;
var
 hour, minute, second, sec100: word;
 el_hr, el_mn, el_sc: word;
begin;
 gettime(hour, minute, second, sec100);
 elapsed(hour, minute, second, st_hr, st_mn, st_sc, el_hr, el_mn, el_sc);
 time_used:=(el_hr*60)+el_mn;
end;

procedure display_Fkeys;
var
 a,b: integer;
 x,y: integer;
begin;
 save_sc:=999;
 x:=wherex;
 y:=wherey;
 cursoroff;
 window(1,1,80,numlines);
 a:=tcolor;
 b:=bcolor;
 textcolor(statfore);
 textbackground(statback);
 gotoxy(1,numlines);
 clreol;
 write(' F1=Help Toggle ? F2=Chat ? F7=+5Min ? F8=-5Min ? F10=Eject ?');
 window(1,1,80,numlines-1);
 gotoxy(x,y);
 textcolor(a);
 textbackground(b);
 If Not NoLocal then cursoron;
 if f1toggle=0 then
  f1toggle:=1
 else
  begin
    firsttime:=true;
    f1toggle:=0
  end;
end;

procedure display_status;
var
 a,b: integer;
 c,d: word;
 x,y: integer;
 hour, minute, second, sec100, el_mn, el_hr, el_sc: word;
begin;
 x:=wherex;
 y:=wherey;
 cursoroff;
 window(1,1,80,numlines);
 a:=tcolor;
 b:=bcolor;
 textcolor(statfore);
 textbackground(statback);

 if firsttime then
   begin
     gotoxy(1,numlines);
     clreol;
     write(user_first_name+' '+user_last_name);
     gotoxy(40-(length(progname+' - Node '+va(node_num)) div 2),numlines);
     write(progname+' - Node '+va(node_num));
     firsttime:=false;
     save_sc:=999;
   end;
 gettime(hour,minute,second,sec100);
 elapsed(hour,minute,second,st_hr,st_mn,st_sc,el_hr,el_mn,el_sc);
 c:=(bbs_time_left-1)+time_credit;
 if (time_left<mintime) and (time_check) then
   begin
     cursoron;
     if notime<>'' then swriteln('(*** Time limit exceeded ***)');
     swriteln('');
     tdropped:=true;
     halt;
   end;
 c:=c-((el_hr*60)+el_mn);
 d:=60-el_sc;
 if d<>save_sc then
   begin
     gotoxy(74,numlines);
     clreol;
     gotoxy(74,numlines);
     write(c,':');
     if d<10 then write('0');
     write(d);
     save_sc:=d;
   end;

 textcolor(a);
 textbackground(b);
 window(1,1,80,numlines-1);
 gotoxy(x,y);
 If Not NoLocal then cursoron;
end;

procedure Selectansi;
var
  f: text;
  b,g,counter,chcount : integer;
  c,quit: boolean;
  k,ch: char;
  ansisave,moresave,swon : boolean;
  ofm: word;
begin
  ofm:=filemode;
  filemode:=66;
  ansisave:=ansion;
  ansion:=true;
  quit:=false;
  counter:=1;
  chcount:=0;
  c:=false;
  swon:=false;
  g:=graphics;
  k:=' ';

  assign(f,'ERROR');
  if pos('.',filenm)<>0 then assign(f,filenm) else
   begin
     while (g>=0) and (not c) do
       begin
         if exist(filenm+graphics_codes[g]) then
           begin
             assign(f,filenm+graphics_codes[g]);
             c:=true;
           end;
         dec(g);
       end;
   end;

 {$I-}
 filemode:=66;
 reset(f);
 filemode:=66;
 {$I+}
 if ioresult<>0 then
   begin
     swriteln('File '+filenm+' missing');
     ansion:=ansisave;
     filemode:=ofm;
     exit;
   end;

 while (not eof(f)) and (not quit) do
  begin
    if ch=#10 then
      begin
        chcount:=0;
        inc(counter);
      end;

    read(f,ch);
    if chcount>0 then
      begin
        if swon then
           swritec(ch);
      end
    else
      begin
        if swon then
          begin
            if ch<>chflag then
              quit:=true;
          end
        else
        if ch=chflag then
          swon:=true;
      end;
    inc(chcount);
   end;

   close(f);
   ansion:=ansisave;
   set_foreground(default_fore);
   filemode:=ofm;
end;

procedure displayfile;
var
  f: text;
  g, counter,b: integer;
  c,quit,nonstop: boolean;
  k,ch: char;
  ansisave,moresave: boolean;
  ofm: word;
begin
  ofm:=filemode;
  filemode:=66;
  ansisave:=ansion;
  ansion:=true;
  nonstop:=false;
  quit:=false;
  counter:=1;
  c:=false;
  g:=graphics;
  k:=' ';
  assign(f,'ERROR');
  if pos('.',filen)<>0 then assign(f,filen) else
   begin
     while (g>=0) and (not c) do
       begin
         if exist(filen+graphics_codes[g]) then
           begin
             if g in [2,3,5] then
               nonstop:=true;
             assign(f,filen+graphics_codes[g]);
             c:=true;
           end;
         dec(g);
       end;
   end;
 {$I-}
 filemode:=66;
 reset(f);
 filemode:=66;
 {$I+}
 if ioresult<>0 then
   begin
     swriteln('File '+filen+' missing - please inform sysop');
     ansion:=ansisave;
     filemode:=ofm;
     exit;
   end;
 while (not eof(f)) and (not quit) do
  begin
    if ch=#10 then inc(counter);
 {  if (counter=24) and (not nonstop) then
      begin
        counter:=1;
        swrite('Continue,Stop,Non-stop ? ');
        sread_char(ch);
        for b:=1 to 26 do
          swrite(chr(8));
        clreol;
       if ch in ['S','s'] then
         Quit:=true;
       if ch in ['N','n'] then
         nonstop:=true;
      end; }
    { remove the comments to implement the pause function }

    read(f,ch);
    if skeypressed then
      sread_char(k);
    if k=^S then
      sread_char(k);
    if (k=^k) or (k=^c) then
      begin
        close(f);
        AsyncPurgeOutput;
        swriteln('');
        ansion:=ansisave;
        filemode:=ofm;
        exit;
      end;
    if not quit then
      swritec(ch);
   end;

   close(f);
   ansion:=ansisave;
   set_foreground(default_fore);
   filemode:=ofm;
end;

procedure SendText(s: string);
var
 a: integer;
begin;
 If (Not AsyncCarrierPresent) then DropMessage;
 for a:=1 to length(s) do AsyncSendChar(s[a]);
end;

procedure CharOut(ch: char);
begin;
 AsyncSendChar(ch);
end;

function charin(var ch: char): boolean;
begin;
 if badchar<>'' then
   begin;
     ch:=badchar[1];
     delete(badchar,1,1);
     charin:=true;
   end
 else
  if AsyncCharPresent then
     begin;
       AsyncReceiveChar(ch);
       charin:=true;
     end
 else charin:=false;
end;

procedure CloseDown;
begin;
  if buffered then
     AsyncFlushOutput;
  If Not noFossinit then
     AsyncCloseCom(com_port);
  buffered := false;
end;

procedure sclrscr;
begin
 if not local then sendtext(#27'[2J');
 If NoLocal then
   begin
     TextColor(statfore);
     TextBackGround(statback);
   end;

 clrscr;
 If NoLocal then BlankScreenMessage;
 curlinenum:=1;
 lastsetfore:=99;
end;

procedure sclreol;
begin;
 if not local then sendtext(#27'[K');
 clreol;
end;

procedure morecheck;
var
 ch: char;
begin;
 swrite('<More>');
 sread_char(ch);
 swrite(#8+#8+#8+#8+#8+#8);
 write('      ');
 write(#8+#8+#8+#8+#8+#8);
end;

procedure swritec(ch: char);
begin;
 if not local then
   AsyncSendChar(ch);
 if NoLocal then
    begin
      gotoxy(Wherex+1,Wherey);
      exit;
    end;
 if ansion then
    ansi_write(ch)
  else
    write(ch);
end;

procedure swrite(s: string);
begin;
 if hexon then hexfilt(s);
 if not local then sendtext(s);
 if NoLocal then
  begin
    GotoXY(wherex+length(s),wherey);
    exit;
  end;

 if ansion then
     ansi_write_str(s)
 else
    write(s);
end;

procedure swriteln(s: string);
begin;
 if hexon then hexfilt(s);
 if not local then sendtext(s+#13+#10);
 if NoLocal then
  begin
    GotoXY(wherex+length(s),wherey);
    writeln;
    exit;
  end;

 if ansion then
   begin
     s:=s+#13+#10;
     ansi_write_str(s);
   end
 else
   writeln(s);
 inc(curlinenum);
 if (curlinenum=(numlines-1)) then begin;
  curlinenum:=1;
  if moreok then morecheck;
 end;
end;

Procedure swritexy;
begin
 Sgoto_XY(x,y);
 if hexon then hexfilt(s);
 if not local then sendtext(s);
 if NoLocal then
  begin
    GotoXY(wherex+length(s),wherey);
    exit;
  end;

 if ansion then
     ansi_write_str(s)
 else
    write(s);
end;

Procedure Propeller(v:byte);
const
  CX :array [1..6] of char =(chr(250),'?','/','-','\','?');
var
  b : byte;
begin
  b:=6;
  case v of
   1,15      : b:=1;
   2,6,10,14 : b:=2;
   3,7,11    : b:=3;
   4,8,12    : b:=4;
   5,9,13    : b:=5;
  end;
  if v < 17 then
    begin
      Swritec(cx[b]);
      SwriteC(#8);
    end;
end;

procedure DDexit;
begin;
 If not local then CloseDown;
 if lastmode<>oldtextmode then textmode(oldtextmode);
 cursoron;
 { This should fix the problem OS/2 serial IO drivers are having exiting. }
 exitproc:=exitsave;
end;

 { Customize this for each game }

Procedure CallProc;
inline($FF/$1E/Proc_Call_Ptr);

Procedure DefineFKeys(var a:char;fkeyon:byte);
begin
  a:=#0;
  case fkeyon of
    1: Display_Fkeys;
    2: begin
         if inchat>0 then exit;
         inchat:=1;
         Forced_Chat;
         inchat:=0;
         a:=#3;
         chatdone:=true;
       end;
    7: inc(time_credit,5);
    8: dec(time_credit,5);
   10: begin
         HosedMessage;
         Halt;
       end;
  end;
end;

procedure sfkeys(var a: char);
var
 fkeyon:byte;
begin
  fkeyon:=0;
   case a of
     #59:fkeyon:=1;
     #60:fkeyon:=2;
     #61:fkeyon:=3;
     #62:fkeyon:=4;
     #63:fkeyon:=5;
     #64:fkeyon:=6;
     #65:fkeyon:=7;
     #66:fkeyon:=8;
     #67:fkeyon:=9;
     #68:fkeyon:=10;
  else
     a:=#0;
  end;
  If a<>#0 then
    DefineFkeys(a,fkeyon);
end;

Procedure ReadScanCode(var a:char);
begin
  a :=readkey;
  if (a=#0