Power-Programmierung/CD1.mdf/pascal/library/dos/ansi/ansi_130/pingansi.pas

Pascal/Delphi Source File | 1990-06-03 | 16.1 KB | 528 lines

{$DEFINE Music}
{$DEFINE BBS}
{$UNDEF Small}
{ $A+,B-,D-,E-,F+,I-,L-,O+,R-,S-,V-}
(*
     PingAnsi v 1.30 (c) CopyRight 1990 P.H.Rankin Hansen.

     This unit provides partial Ansi emulation for Turbo Pascal versions
     5.x and higher. (version 4 does not support procedural types). Some
     routines are handled in a non-standard way.

     Released in Denmark on June 3rd 1990.

     By  using  this  material  You  assume  FULL responsibility for ANY
     consequences  -  direct  or   indirect  -  thereof.
     Any dispute regarding this material shall be setteled by Danish law
     and in a Danish Court.

     (Sigh!)

     This  source may  NOT be  used by  Lawyers, Politicians or, persons
     engaged  in any  other form  of terrorism.  Otherwise the  usage is
     free.

     This source may be freely distributed as long as no fee is charged.

     Please direct any comments,  corrections, modifications via netmail
     to:

                      Ping Hansen - Fido Net 2:231/62.58

*)

Unit PingAnsi;
  {-}
Interface
Uses

  { Standard units }
  Dos,
  { Turbo Power units. The standard CRT unit will not work in a TSR }
  TpCrt, TpString;

Const
  Title               = 'PingAnsi v1.30 (c) CopyRight P.H.Rankin Hansen 1990.';

Var
  Ansi                : Text;     { Ansi is the name of the device }
  Wrap                : Boolean;  { True if Cursor should wrap }
  ReportedX,
  ReportedY           : Word;     { X,Y reported }

  { hook for implementing Your own Device Status Report procedure }
  ReplyHook           : Procedure(St : String);

  { hook for implementing Your own KeyBoard ReAssignment }
  KeyHook             : Procedure(St : String);

  { Hook for handling control chars i.e. Ch < Space }
  WriteHook           : Procedure(Ch : Char);

  {$IFNDEF Small}
  {$IFDEF BBS}

  { Hook for handling simultaneous writes to ComPort and Screen }
  BBsHook       : Procedure (Ch : Char);

  {$ENDIF}
  {$ENDIF}

  {$IFDEF Music}

  { Hook for handling music }
  PlayHook  : Procedure(St : String);

  {$ENDIF}

Function In_Ansi    : Boolean;    { True if a sequence is pending }
Procedure AnsiWrite(Ch : Char);

  {$IFNDEF Small}

Procedure AssignAnsi(Var f : Text); { use like AssignCrt }

  {$ENDIF}

Implementation

Type
  States              = (Waiting, Bracket, Get_Args, Get_Param, Eat_Semi,
                         Get_String, In_Param, Get_Music);
Const
  St                  : String = '';
  ParamArr            : Array[1..10] Of Word = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
  Params              : Word = 0; { number of parameters }
  NextState           : States = Waiting; { next state for the parser }
  Reverse             : Boolean = False; { true if text attributes are reversed }

Var
  Quote               : Char;
  SavedX, SavedY      : Word;

  Function In_Ansi    : Boolean;  { True if a sequence is pending }
  Begin
    In_Ansi := (NextState <> Waiting) And (NextState <> Bracket);
  End {In_Ansi} ;


  {$F+}
  Procedure Report(St : String);
    {$F-}
  Begin
    StuffString(St);
  End;

  {$F+}
  Procedure WriteChar(Ch : Char);
    {$F-}
  Begin
    Case Ch Of
      #7 :
        Begin
          NoSound;
          Sound(500);
          Delay(50);
          NoSound;
          Delay(50);
        End;
      #8 : If (WhereX > 1) Then Write(#8' '#8);
      #9 : If (WhereX < 71) Then
           Repeat
             GotoXy(WhereX + 1, Wherey);
           Until (WhereX Mod 8 = 1);
      Else
        Write(Ch);
    End {Case} ;
  End {WriteChar} ;

  {$F+}
  Procedure Dummy(St : String);
    {$F-}
  Begin
  End;

  Procedure AnsiWrite(Ch : Char);

  Var
    i                   : Word;

  Label Command;

  Begin
    If Ch = #27 Then
    Begin
      NextState := Bracket;
      Exit;
    End;
    Case NextState Of
      Waiting : If (Ch > ' ') Then Write(Ch)
                Else WriteHook(Ch);
      Bracket :
        Begin
          If Ch <> '[' Then
          Begin
            NextState := Waiting;
            If (Ch > ' ') Then Write(Ch)
            Else WriteHook(Ch);
            Exit;
          End;
          St := '';
          Params := 1;
          FillChar(ParamArr, 10, 0);
          NextState := Get_Args;
        End;
      Get_Args, Get_Param, Eat_Semi :
        Begin
          {$IFNDEF Music}
          If (NextState = Get_Args) And ((Ch = '=') Or (Ch = '?')) Then
          Begin
            NextState := Get_Param;
            Exit;
          End;
          {$ELSE}
          If (NextState = Get_Args) Then
            Case Ch Of
              '=', '?' :
                Begin
                  NextState := Get_Param;
                  Exit;
                End;
              'M' :
                Begin
                  NextState := Get_Music;
                  Exit;
                End;
            End {Case} ;
          {$ENDIF}
          If (NextState = Eat_Semi) And (Ch = ';') Then
          Begin
            If Params < 10 Then Inc(Params);
            NextState := Get_Param;
            Exit;
          End;
          Case Ch Of
            '0'..'9' :
              Begin
                ParamArr[Params] := Ord(Ch) - Ord('0');
                NextState := In_Param;
              End;
            ';' :
              Begin
                If Params < 10 Then Inc(Params);
                NextState := Get_Param;
              End;
            '"', '''' :
              Begin
                Quote := Ch;
                St := St + Ch;
                NextState := Get_String;
              End;
            Else
              GoTo Command;
          End {Case Ch} ;
        End;
      Get_String :
        Begin
          St := St + Ch;
          If Ch <> Quote
          Then NextState := Get_String
          Else NextState := Eat_Semi;
        End;
      In_Param :                  { last char was a digit }
        Begin
          { looking for more digits, a semicolon, or a command char }
          Case Ch Of
            '0'..'9' :
              Begin
                ParamArr[Params] := ParamArr[Params] * 10 + Ord(Ch) - Ord('0');
                NextState := In_Param;
                Exit;
              End;
            ';' :
              Begin
                If Params < 10 Then Inc(Params);
                NextState := Eat_Semi;
                Exit;
              End;
          End {Case Ch} ;
Command:
          NextState := Waiting;
          Case Ch Of
            { Note: the order of commands is optimized for execution speed }
            'm' :                 {sgr}
              Begin
                For i := 1 To Params Do
                Begin
                  If Reverse Then TextAttr := TextAttr Shr 4 + TextAttr Shl 4;
                  Case ParamArr[i] Of
                    0 :
                      Begin
                        Reverse := False;
                        TextAttr := 7;
                      End;
                    1 : TextAttr := TextAttr And $FF Or $08;
                    2 : TextAttr := TextAttr And $F7 Or $00;
                    4 : TextAttr := TextAttr And $F8 Or $01;
                    5 : TextAttr := TextAttr Or $80;
                    7 : If Not Reverse Then
                        Begin
                      {
                      TextAttr := TextAttr shr 4 + TextAttr shl 4;
                      }
                          Reverse := True;
                        End;
                    22 : TextAttr := TextAttr And $F7 Or $00;
                    24 : TextAttr := TextAttr And $F8 Or $04;
                    25 : TextAttr := TextAttr And $7F Or $00;
                    27 : If Reverse Then
                         Begin
                           Reverse := False;
                      {
                      TextAttr := TextAttr shr 4 + TextAttr shl 4;
                      }
                         End;
                    30 : TextAttr := TextAttr And $F8 Or $00;
                    31 : TextAttr := TextAttr And $F8 Or $04;
                    32 : TextAttr := TextAttr And $F8 Or $02;
                    33 : TextAttr := TextAttr And $F8 Or $06;
                    34 : TextAttr := TextAttr And $F8 Or $01;
                    35 : TextAttr := TextAttr And $F8 Or $05;
                    36 : TextAttr := TextAttr And $F8 Or $03;
                    37 : TextAttr := TextAttr And $F8 Or $07;
                    40 : TextAttr := TextAttr And $8F Or $00;
                    41 : TextAttr := TextAttr And $8F Or $40;
                    42 : TextAttr := TextAttr And $8F Or $20;
                    43 : TextAttr := TextAttr And $8F Or $60;
                    44 : TextAttr := TextAttr And $8F Or $10;
                    45 : TextAttr := TextAttr And $8F Or $50;
                    46 : TextAttr := TextAttr And $8F Or $30;
                    47 : TextAttr := TextAttr And $8F Or $70;
                  End {Case} ;
                  { fixup for reverse }
                  If Reverse Then TextAttr := TextAttr Shr 4 + TextAttr Shl 4;
                End;
              End;
            'A' :                 {cuu}
              Begin
                If ParamArr[1] = 0 Then ParamArr[1] := 1;
                If (Wherey - ParamArr[1] >= 1)
                Then GotoXy(WhereX, Wherey - ParamArr[1])
                Else GotoXy(WhereX, Hi(WindMax));
              End;
            'B' :                 {cud}
              Begin
                If ParamArr[1] = 0 Then ParamArr[1] := 1;
                If (Wherey + ParamArr[1] <= Hi(WindMax))
                Then GotoXy(WhereX, Wherey + ParamArr[1])
                Else GotoXy(WhereX, 1);
              End;
            'C' :                 {cuf}
              Begin
                If ParamArr[1] = 0 Then ParamArr[1] := 1;
                If WhereX + ParamArr[1] <= Lo(WindMax)
                Then GotoXy(WhereX + ParamArr[1], Wherey)
                Else GotoXy(Lo(WindMax), Wherey);
              End;
            'D' :                 {cub}
              Begin
                If ParamArr[1] = 0 Then ParamArr[1] := 1;
                If (WhereX - ParamArr[1] >= 1)
                Then GotoXy(WhereX - ParamArr[1], Wherey)
                Else GotoXy(1, Wherey);
              End;
            'H', 'f' :            {cup,hvp}
              Begin
                If ParamArr[1] = 0 Then ParamArr[1] := 1;
                If ParamArr[2] = 0 Then ParamArr[2] := 1;
                GotoXy(ParamArr[2], ParamArr[1]);
              End;
            'J' :                 {EID}
              Case ParamArr[1] Of
                2 : ClrScr;
                0 :               {ClrEos}
                  Begin
                    ClrEol;
                    ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey + 1,
                                     Lo(WindMax) + 1, Hi(WindMax) + 1, 0);
                  End;
                1 :               {Clear from beginning of screen}
                  Begin
                    ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
                                     Lo(WindMin) + WhereX,
                                     Hi(WindMin) + Wherey, 0);
                    ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + 1,
                                     Lo(WindMax) + 1, Hi(WindMin) + Wherey - 1, 0);
                  End;
              End {Case} ;
            'K' :                 {eil}
              Case ParamArr[1] Of
                0 : ClrEol;
                1 :               { clear from beginning of line to cursor }
                  ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
                                   Lo(WindMin) + WhereX - 1,
                                   Hi(WindMin) + Wherey, 0);
                2 :               { clear entire line }
                  ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
                                   Lo(WindMax) + 1,
                                   Hi(WindMin) + Wherey, 0);
              End {Case ParamArr} ;
            'L' : {il } For i := 1 To ParamArr[1] Do InsLine; { must not move cursor }
            'M' : {d_l} For i := 1 To ParamArr[1] Do DelLine; { must not move cursor }
            'P' :                 {dc }
              Begin
              End;
            'R' :                 {cpr}
              Begin
                ReportedY := ParamArr[1];
                ReportedX := ParamArr[2];
              End;
            '@' :                 {ic}
              Begin
                { insert blank chars }
              End;
            'h', 'l' :            {sm/rm}
              Case ParamArr[1] Of
                0 : TextMode(BW40);
                1 : TextMode(CO40);
                2 : TextMode(BW80);
                3 : TextMode(CO80);
                4 : {GraphMode(320x200 col)} ;
                5 : {GraphMode(320x200 BW)} ;
                6 : {GraphMode(640x200 BW)} ;
                7 : Wrap := Ch = 'h';
              End {case} ;
            'n' :                 {dsr}
              If (ParamArr[1] = 6) Then
                ReplyHook(#27'[' + Long2str(Wherey) + ';' +
                          Long2str(WhereX) + 'R');
            's' :                 {scp}
              Begin
                SavedX := WhereX;
                SavedY := Wherey;
              End;
            'u' : {rcp} GotoXy(SavedX, SavedY);
            'p' :                 {keyboard reassignment}
              KeyHook(St);
            Else
              Begin
                If (Ch > ' ') Then Write(Ch)
                Else WriteHook(Ch);
                Exit;
              End;
          End {Case Ch} ;
        End;
      {$IFDEF Music}
      Get_Music :
        Begin
          If Ch <> #3             {Ctrl-C}
          Then St := St + Ch
          Else
          Begin
            NextState := Waiting;
            PlayHook(St);
          End;
        End;
      {$ENDIF}
    End {Case NextState} ;
  End {AnsiWrite} ;

  {$IFNDEF Small}

  {$F+}                           { All Driver function must be far }

  Function Nothing(Var f : TextRec) : Integer;
  Begin
    Nothing := 0;
  End {Nothing} ;

  Procedure Null(Ch : Char);
  Begin
    {}
  End {Null} ;

  Function DevOutput(Var f : TextRec) : Integer;
  Var
    i                   : Integer;
  Begin
    With f Do
    Begin
      { f.BufPos contains the number of chars in the buffer }
      { f.BufPtr^ is your buffer                            }
      { Any variable conversion done by writeln is already  }
      { done by now.                                        }
      i := 0;
      While i < BufPos Do
      Begin
        AnsiWrite(BufPtr^[i]);
        {$IFDEF BBS}
        BBSHook(BufPtr^[i]);
        {$ENDIF}
        Inc(i);
      End;
      BufPos := 0;
    End;
    DevOutput := 0;               { return IOResult Error codes here }
  End {DevOutput} ;

  Function DevOpen(Var f : TextRec) : Integer;
  Begin
    With f Do
    Begin
      If Mode = FmInput Then
      Begin
        InOutFunc := @Nothing;
        FlushFunc := @Nothing;
      End
      Else
      Begin
        Mode := FmOutput;         { in case it was FmInOut }
        InOutFunc := @DevOutput;
        FlushFunc := @DevOutput;
      End;
      CloseFunc := @Nothing;
    End;
    DevOpen := 0;                 { return IOResult error codes here }
  End {DevOpen} ;

  Procedure AssignAnsi(Var f : Text);
  Begin
    FillChar(f, SizeOf(f), #0);   { init file var }
    With TextRec(f) Do
    Begin
      Handle := $ffff;
      Mode := FmClosed;
      BufSize := SizeOf(Buffer);
      BufPtr := @Buffer;
      OpenFunc := @DevOpen;
      Name[0] := #0;
    End;
  End {AssignAnsi} ;
  {$ENDIF}

Begin

  {$IFNDEF Small}

  AssignAnsi(Ansi);               { set up the variable }
  Rewrite(Ansi);                  { open it for output  }

  {$IFDEF BBS}

    BBsHook := Null;

  {$ENDIF}
  {$ENDIF}

  Wrap := True;
  ReplyHook := Report;
  KeyHook := Dummy;
  WriteHook := WriteChar;

  {$IFDEF Music}

  PlayHook := Dummy; { point play into the great music heaven }

  {$ENDIF}
End.