[Back to ANSI SWAG index] [Back to Main SWAG index] [Original]

    Unit AnsiUnit;
    {$Q-}
    {$R-}
    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 WriteChar(Ch : Char);
    Procedure AnsiWrite(S: String);

    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(S: String);

      Var
        i                   : Word;
        j                   : Byte;
        Ch                  : Char;

      Label Command, Ending;

      Begin
        for j := 1 to length(S) do
        begin
          Ch := s[j];
          If Ch = #27 Then
          Begin
            NextState := Bracket;
            Goto Ending;
          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);
                  Goto Ending;
                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;
                  Goto Ending;
                End;
                {$ELSE}
                If (NextState = Get_Args) Then
                  Case Ch Of
                    '=', '?' :
                      Begin
                        NextState := Get_Param;
                        Goto Ending;
                      End;
                    'M' :
                      Begin
                        NextState := Get_Music;
                        Goto Ending;
                      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;
                      Goto Ending;
                    End;
                  ';' :
                    Begin
                      If Params < 10 Then Inc(Params);
                      NextState := Eat_Semi;
                      Goto Ending;
                    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);
                      Goto Ending;
                    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} ;
          Ending:
        End;
      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.

[Back to ANSI SWAG index] [Back to Main SWAG index] [Original]