Beijing Paradise BBS Backup/PARADISE.ISO/software/BBSDOORW/RADOOR30.ZIP/DRIVER.PAS

Pascal/Delphi Source File | 1994-04-10 | 19.4 KB | 672 lines

{╔═════════════════════════════════════════════════════════════════════════╗
 ║                                                                         ║
 ║                   (c) CopyRight LiveSystems 1990, 1994                  ║
 ║                                                                         ║
 ║ Author    : Gerhard Hoogterp                                            ║
 ║ FidoNet   : 2:282/100.5   2:283/7.33                                    ║
 ║ BitNet    : [e-mail]                                     ║
 ║                                                                         ║
 ║ SnailMail : Kremersmaten 108                                            ║
 ║             7511 LC Enschede                                            ║
 ║             The Netherlands                                             ║
 ║                                                                         ║
 ║        This module is part of the RADoor BBS doorwriters toolbox.       ║
 ║                                                                         ║
 ╚═════════════════════════════════════════════════════════════════════════╝}
{ Current problems/bugs:

* The AVATAR ^V^Y routine doesn't work recursive. Well, this is a problem
  seen with more AVT/0+ implementation. Still working on a decent way to
  implement this sequence the right way. (The Status variable is the killer,
  Since it's a globaly define variable so the status is remembered between
  calls.. It's a disadvantage of the stream-like way of implementing..)

- 2 aug 91
   Added support for special ANSI codes. With these you can use this unit for
   an special door-terminal and let the doorgame send codes for loading
   backdrops, moving object coordinates or REAL music..
   F.e.:
          <ESC>[<BackdropNr>b   (Note the SMALL 'b'!)
            Load backdrop no. <BackDropNr>

          <Esc>[<VOCname>V
            Play VOC file

          Etc.
  Make sure that the ANSI-indentifier isn't in use yet. The original ANSI
  codes are checked first!

  b.t.w. Don't use sequences longer than a string, including the <ESC>[
  and the trailing indentifier!

  An other tip.. If you want to send text (which is not possible normaly
  because it usualy contains ANSI indentifiers!) set the 8th bit and reset it
  after receiving. ANSI doesn't use Character above the 128 anyhow...

* Added an compiler directive EatCursorReq. If Not selected, the normal
  Ansi detection doesn't detect the <ESQ>[6n cursor position request
  anymore. This way you can implement it as an special ANSI code, and
  send back the cursor position. This system is often used for
  detecting if a terminal has ANSI support. (This one is also for
  special terminal use..)

- 12 Feb 92: Release


}

{ Define Debug       } { Turn on AVATAR debugging                           }
{$Define UseMusic    } { Just eat music if un-selected                      }
{ Define normalBeep  } { Use the normal #7 beep                             }

Unit Driver;
Interface
Uses {$IfDef UseMusic}
        AnsiMus,
     {$EndIf}
      CRT;

Const AddedSet : String[64] = '';  { Implement extra, special ANSI codes }

Type  DoAddedANSIType = Procedure(Buf : String);
                           { The procedure to process the special ANSI codes }
                           { you can use this in a special game-terminal to  }
                           { Load backgrounds from the local HD or to play   }
                           { REAL (Soundblaster? ADLib?) music during the    }
                           { game.. Many possibilites! See DrvDemo.Pas for   }
                           { an simple example..                             }

Var  NoColor   : Boolean;  { Replaces the old Monochrome variable  }
     BeQuiet   : Boolean;  { Don't beep at the local screen        }
     RACode    : Boolean;  { True when the character isn't part of }
                           { an ansi/avatar sequence.              }
     AnsiDetect: Boolean;  { Is set to true when a ^]]x;yR is      }
                           { received                              }

     DoAddedANSI : DoAddedANSIType;

{ Comment: (Mon  02-04-1991, 23:07:27)
|-----------------------------------------------------------------------------|
  Just throw characters into the driver and ansi/avatar sequences will be
  inpretered correctly. Character not recognised go to the local screen.
|-----------------------------------------------------------------------------|
}

Procedure ScreenDriver(C : Char);
Procedure InitDriver;


Function StatusResult:String;
Function GotRequest:Boolean;

{$IfDef Debug}
Procedure DebugIt(Line : String);
Procedure FlushDebug;
{$EndIf} {Debug}

Implementation


{$IfDef Debug}
Type DebugArray = Array[1..100] Of String[20];
Var  Debug : DebugArray;
     DPtr  : Byte;

Procedure DebugIt(Line : String);
Const HexChar : Array[0..$F] of Char = '0123456789ABCDEF';
Var Out : Text;
    C   : Byte;
    Log : String[80];
Begin
Log:='^'+Chr(Ord(Line[1])+64);
If Length(Line)>1
   Then Log:=Log+' ^'+Chr(Ord(Line[2])+64);
For C:=3 To Length(Line) Do
 Log:=Log+' #'+HexChar[(Ord(Line[C]) And $F0) Shr 4]+HexChar[Ord(Line[C]) And $0F];
Inc(DPtr);
If DPtr>100
   Then Begin
        Assign(Out,'AVATAR.LOG');
        Append(Out);
        If IoResult<>0
           Then Rewrite(Out);
        For C:=1 to 100 Do
         WriteLn(Out,Debug[C]);
        Close(Out);
        DPtr:=1;
        End;
Debug[DPtr]:=Log;
End;

Procedure FlushDebug;
Var Out : Text;
    C   : Byte;
Begin
Assign(Out,'AVATAR.LOG');
Append(Out);
If IoResult<>0
   Then Rewrite(Out);
For C:=1 to 100 Do
 WriteLn(Out,Debug[C]);
Close(Out);
End;
{$EndIf} {Debug}



Procedure NiceBeep;
Var Nice : Longint;
Begin
NoSound;
For Nice:=1000 to 3000 Do
 Sound(Nice);
NoSound;
End;

Const AnsiSet          = 'mABCDsufHhJKlnR'#14;

Type DrvStat = (Normal,Ansi,Avatar,Music);

Const Status : DrvStat = Normal;
      DefaultColor : Byte =$03;
      CurrentColor : Byte =$03;

Var   Buf        : String;
      AvMX,AvMy  : Byte;
      AnMx,AnMy  : Byte;
      AnsiWrap   : Boolean;
      HiColor    : Boolean;
      LastCol    : Byte;

      AVTIns     : Boolean;
      RepLen     : Byte;

      SendBack   : String;
      GotReq     : Boolean;

Function Str2Nr(S : String):Word;
Var Temp : Word;
    Err  : Word;
Begin
Val(S,Temp,Err);
If Err<>0
   Then Str2Nr:=0
   Else Str2Nr:=Temp;
End;

Type Str3 = String[3];

Function Nr2Str(N : Byte):Str3;
Var Temp : Str3;
Begin
Str(N,Temp);
Nr2Str:=Temp;
End;

Procedure InitDriver;
Begin
Window(1,1,80,24);
RACode:=False;
BeQuiet:=False;
NoColor:=False;

AnsiDetect:=False;
GotReq:=False;
SendBack:='';

Buf:='';
AnsiWrap:=True;
HiColor:=False;
LastCol:=7;

AVTIns:=False;
End;

Function StatusResult:String;
Begin
StatusResult:=SendBack;
GotReq:=False;
End;

Function GotRequest:Boolean;
Begin
GotRequest:=GotReq;
End;


Procedure Clip(I: Char; X,Y : Byte);
Begin
Case I Of
 'A' : Begin
       If WhereY<=Y
          Then GotoXy(WhereX,1)
          Else GotoXy(WhereX,WhereY-Y);
       End;
 'B' : Begin
       If (WhereY+Y)>25
          Then GotoXy(WhereX,24)
          Else GotoXy(WhereX,WhereY+Y);
       End;
 'C' : Begin
       If (WhereX+X)>80
          Then GotoXy(80,WhereY)
          Else GotoXy(WhereX+X,WhereY);
       End;
 'D' : Begin
       If (WhereX<=X)
          Then GotoXy(1,WhereY)
          Else GotoXy(WhereX-X,WhereY);
       End;
End; {Case}
End;

Procedure DoColor(Color : Byte);
Const LForColors  : Array[0..7] Of Byte = (0,4,2,6,1,5,3,7);
      HForColors  : Array[0..7] Of Byte = (8,12,10,14,9,13,11,15);
      BackColors  : Array[0..7] Of Byte = (0,4,2,6,1,5,3,7);
Begin
If Color <= 8
   Then Begin
        Case Color Of
          0 : Begin
              HiColor:=False;
              TextAttr:=$0F;
              End;
          1 : Begin
              HiColor:=True;
              TextColor(HForColors[LastCol]);
              End;
          5 : TextAttr:=TextAttr Or $80;
        End;
        Exit
        End;
If (Color In [30..37]) And
   (Not NoColor)
   Then Begin
        Dec(Color,30);
        LastCol:=Color;
        TextAttr:=TextAttr And $F0;
        If HiColor
           Then TextAttr:=TextAttr+HForColors[Color]
           Else TextAttr:=TextAttr+LForColors[Color];
        Exit;
        End;
If (Color In [40..47]) And
   (Not NoColor)
   Then Begin
        TextAttr:=TextAttr And $8F;
        TextAttr:=TextAttr+(BackColors[Color-40] Shl 4);
        End;
End;

Procedure DoAnsi(S : String);
Var Indent : Char;
    X,Y    : Byte;
    TStr   : String[10];
    Color  : Byte;
    DPos   : Byte;
    Err    : Integer;

Begin
Delete(S,1,2);
Indent:=S[Length(S)];
Dec(Byte(S[0]));
Case Indent Of
 'm'   : Begin
         While S<>'' Do
          Begin
          DPos:=Pos(';',S);
          If DPos>0
             Then Begin
                  TStr:=Copy(S,1,DPos-1);
                  Delete(S,1,DPos);
                  End
             Else Begin
                  TStr:=S;
                  S[0]:=#00;
                  End;
          VAL(TStr,Color,Err);
          DoColor(Color);
          End;
         End;
 'A',
 'B',
 'C',
 'D'   : Begin
         If S=''
            Then Begin
                 X:=1;
                 Y:=1;
                 End
            Else Begin
                 X:=Str2Nr(S);
                 Y:=X;
                 End;
         Clip(Indent,X,Y);
         End;
 's'   : Begin
         AnMx:=WhereX;
         AnMy:=WhereY;
         End;
 'n'   : Begin
         GotReq:=True;
         SendBack:=#27'['+Nr2Str(WhereY)+';'+Nr2Str(WhereX)+'R';
         End;
 'u'   : GotoXy(AnMx,AnMy);
 'f',
 'H'   : Begin
         If Length(S)=0
            Then GotoXy(1,1)
            Else Begin
                 DPos:=Pos(';',S);
                 TStr:=Copy(S,1,DPos-1);
                 If TStr=''
                    Then Begin
                         If DPos=0
                            Then Begin
                                 Val(S,Y,Err);
                                 S[0]:=#00;
                                 End
                            Else Begin
                                 Y:=1;
                                 Delete(S,1,1);
                                 End;
                         End
                    Else Begin
                         Val(TStr,Y,Err);
                         Delete(S,1,DPos);
                         End;
                 If S=''
                    Then X:=1
                    Else Val(S,X,Err);
                 GotoXy(X,Y);
                 End;
         End;
 'J'   : If S='2'
            Then CRt.ClrScr;
 'l'   : If S='=7'
            Then AnsiWrap:=True;
 'K'   : If S=''
            Then CRT.ClrEol;
 'R'   : AnsiDetect:=True;
End; {Case}
End;

Procedure DoAvatar(S : String);
Var Count : Byte;
    X,Y   : Byte;
    RepStr: String;
    MWMin,
    MWMax : Word;

Begin
{$IfDef Debug}
  DebugIt(S);
{$EndIf} {Debug}

Case S[1] Of
 ^Y : Begin
      For Count:=1 To Ord(S[3]) Do
         Write(S[2]);
      End;
 ^V : Begin
        Case S[2] Of
          ^A  : If Not NoColor
                   Then CurrentColor:=Ord(S[3]);
          ^B  : If Not NoColor
                   Then CurrentColor:=CurrentColor Or $80;
          ^C  : If WhereY>1
                   Then GotoXy(WhereX,WhereY-1);
          ^D  : If WhereY<25
                   Then GotoXy(WhereX,WhereY+1);
          ^E  : If WhereX>1
                   Then GotoXy(WhereX-1,WhereY);
          ^F  : If WhereX<80
                   Then GotoXy(WhereX+1,WhereY);
          ^G  : Crt.ClrEol;
          ^H  : GotoXy(Ord(S[4]),Ord(S[3]));
          ^J  : Begin
                AvMX:=WhereX; AvMY:=WhereY;
                MWMin:=WindMin;
                MWMAx:=WindMax;
                Window(Ord(S[5]),Ord(S[4]),Ord(S[7]),Ord(S[6]));
                For Count:=1 To Ord(S[3]) Do
                 DelLine;
                WindMin:=MWMin;
                WindMAx:=MWMax;
                GotoXy(AvMX,AvMY);
                End;
          ^K  : Begin
                AvMX:=WhereX; AvMY:=WhereY;
                MWMin:=WindMin;
                MWMAx:=WindMax;
                Window(Ord(S[5]),Ord(S[4]),Ord(S[7]),Ord(S[6]));
                For Count:=1 To Ord(S[3]) Do
                 InsLine;
                WindMin:=MWMin;
                WindMAx:=MWMax;
                GotoXy(AvMX,AvMY);
                End;
          ^L  : Begin
                AvMX:=WhereX;AvMY:=WhereY;
                MWMin:=WindMin;
                MWMAx:=WindMax;
                Window(AvMX,AvMY,AvMx+Ord(S[5]),AvMY+Ord(S[4]));
                TextAttr:=(Ord(S[3]) And $7F);
                ClrScr;
                WindMin:=MWMin;
                WindMAx:=MWMax;
                GotoXy(AvMX,AvMy);
                CurrentColor:=TextAttr;
                End;
          ^M  : Begin
                AvMX:=WhereX;AvMY:=WhereY;
                If (Ord(S[3]) And $80)=$80
                   Then Begin
                        CurrentColor:=Ord(S[3]) AND $7F;
                        TextAttr:=Ord(S[3]);
                        End
                   Else TextAttr:=(Ord(S[3]) Or $7F);
                RepStr:='';
                For X:= AVMx To AvMX+Ord(S[6])-1 Do
                  RepStr:=RepStr+S[4];
                For Y:= AVMy To AvMY+Ord(S[5])-1 Do
                  Begin
                  GotoXy(AvMX,Y);
                  Write(RepStr);
                  End;
                GotoXy(AvMX,AvMy);
                End;
          ^Y  : Begin
                RepStr:=S;
                Delete(RepStr,1,3);
                Dec(RepStr[0]);
                For X:=1 To Ord(S[Length(S)]) Do
                 Write(RepStr);
                End;
         End; {Case}
        End; { ^V }
End; {Case}
TextAttr:=CurrentColor;
End;

Procedure ScreenDriver(C : Char);
Var Buffed : Boolean;
Begin
Repeat
 Buffed:=False;
 Case Status Of
  Normal : Begin
           Case C of
            #00  :;
            #27  : Begin
                   Status:=Ansi;
                   Buf:=C;
                   End;
            #09  : Write('        ');
            ^L   : Begin
                   DefaultColor :=$03;
                   CurrentColor :=$03;
                   TextAttr:=CurrentColor;
                   CRT.ClrScr;
                   AVTIns:=False;
                   End;
            ^Y,
            ^V   : Begin
                   Status:=Avatar;
                   Buf:=C;
                   RepLen:=0;
                   End;
           Else    Begin
                   If (C=#7) And (Not BeQuiet)
                      Then {$IfDef NormalBeeb}
                             Write(#7);
                           {$Else}
                             NiceBeep;
                           {$EndIf}
                   If (C<>#7)
                      Then Write(C);
                   End;
          End; {Case}
          End;

  Ansi   : Begin
           If (Buf=#27'[M') And
              (Upcase(C) In ['F','B'])
              Then Begin
                   NoSound;
                   Status:=Music;
                   End
              Else Begin
                   Buf:=Buf+C;
                   If Pos(C,AnsiSet)>0
                      Then Begin
                           Status:=Normal;
                           DoAnsi(Buf);
                           End;

                   If (AddedSet<>'') And       { 2/8/91, special ANSI support }
                      (Pos(C,AddedSet)>0)
                      Then Begin
                           Status:=Normal;
                           DoAddedANSI(Buf);
                           End;
                   End;
           End;
   Music : Begin
           If C <#32
              Then Begin
                   If (C<>#14) And
                      (C<>#13)
                      Then Buffed:=True;
                   Status:=Normal;
                   NoSound;
                   {$IfDef UseMusic}
                    ResetMusic;
                   {$EndIf}
                   End
              Else Begin
                   {$IfDef UseMusic}
                     If Not BeQuiet
                        Then AnsiMusic(Upcase(C));
                   {$EndIf}
                   End;
           End;
  Avatar : Begin
           Buf:=Buf+C;
           Case Buf[1] Of
            ^V  : Begin
                  If Buf[2]<>^Y
                     Then AVTIns:=False;
                  Case Buf[2] Of
                   ^A : Begin
                        If Length(Buf)=3
                           Then Begin
                                Status:=Normal;
                                DoAvatar(Buf);
                                End;
                        End;
                   ^B,
                   ^C,
                   ^D,
                   ^E,
                   ^F,
                   ^G  : Begin
                         Status:=Normal;
                         DoAvatar(Buf);
                         End;
                   ^H  : Begin
                         If Length(Buf)=4
                            Then Begin
                                 Status:=Normal;
                                 DoAvatar(Buf);
                                 End;
                         End;
                   ^I  : AVTIns:=True;
                   ^J,
                   ^K  : Begin
                         If Length(Buf)=7
                            Then Begin
                                 Status:=Normal;
                                 DoAvatar(Buf);
                                 End;
                         End;
                   ^L  : Begin
                         If Length(Buf)=5
                            Then Begin
                                 Status:=Normal;
                                 DoAvatar(Buf);
                                 End;
                         End;
                   ^M  : Begin
                         If Length(Buf)=6
                            Then Begin
                                 Status:=Normal;
                                 DoAvatar(Buf);
                                 End;
                         End;
                   ^Y  : Begin
                         Case Length(Buf) Of
                          3   : RepLen:=Ord(C)+4;
                          Else Begin
                               If Length(Buf)=RepLen
                                  Then Begin
                                       Status:=Normal;
                                       DoAvatar(Buf);
                                       End;
                               End;
                         End; {Case}
                         End;
                  End; { Case }
                  End;  { Case ^V }
            ^Y  : Begin
                  If Length(Buf)=3
                     Then Begin
                          Status:=Normal;
                          DoAvatar(Buf);
                          End;
                  End;
           End; {Case}
           End;
 End; {Case}
Until Not Buffed;
RACode:=Status=Normal;
End;

{$F+}
Procedure NoAddedAnsi(Buf : String);
{$F-}
Begin
End;

Begin
DirectVideo:=False;
InitDriver;

{$IfDef Debug}
 DPtr:=0;
{$EndIf} {Debug}

DoAddedANSI:=NoAddedANSI; { Init a dummy special ansi driver. }
End.