C!T ROM 2/ctrom_ii_b.zip/ctrom_ii_b/PROGRAM/PASCAL/CUNIT_20/ANSIUNIT.PAS

Pascal/Delphi Source File | 1992-03-18 | 15KB | 463 lines

Unit AnsiUnit;

Interface

Uses  Dos, Crt;

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 handling control chars i.e. Ch < Space }
  WriteHook           : Procedure(Ch : Char);

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

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

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

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

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} ;

  Function ms(w: word): string;

    var s: string;

    begin
      str(w,s);
      Ms := s;
    end;


  {$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'[' + ms(Wherey) + ';' +
                          ms(WhereX) + 'R');
            's' :                 {scp}
              Begin
                SavedX := WhereX;
                SavedY := Wherey;
              End;
            'u' : {rcp} GotoXy(SavedX, SavedY);
            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;
          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

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

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

End.