{$IFNDEF OS2}
{$R-,V-,B-,F+,O+,A-,I-}
{$ENDIF}

{*********************************************************}
{*                                                       *}
{*                       ANSI.PAS                        *}
{*                                                       *}
{*     Copyright (c) Konstantin Klyagin, 1995-98.        *}
{*                   expecialy for Tornado BBS system    *}
{*                                                       *}
{*********************************************************}

Unit Ansi;
  {-Does ANSI screen writing and produces ANSI sequences}

Interface

Uses

{$IFDEF MSDOS}
  ApMisc,
{$ENDIF}

{$IFDEF OS2}
  ApOS2,
{$ENDIF}

{$IFNDEF WIN32}
  ApTimer,
{$ELSE}
  SysUtils,
  WApro,
  Console,
{$ENDIF}

  OpCrt,
  tMisc,
  tGlob;

Type
  ClearScreenProc = Procedure;
  SoundBellProc = Procedure;

Const
  {Prevent remote from changing our video mode}
  UseVT100Mode : Boolean = False;
  MaskBlinkOnInverse : Boolean = True;
  InhibitAutoLF : Boolean = False;
  ToBell : Boolean = True;
  ColorArray : Array [0..7] Of Integer = (0, 4, 2, 6, 1, 5, 3, 7);

Procedure WriteCharAnsi (C : Char);
  {-Writes C (and handles ANSI escape sequences)}

Procedure WriteStringAnsi (S : String);
  {-Writes S (and handles ANSI escape sequences)}

Procedure SetClearScreenProc (CSP : ClearScreenProc);
  {-Sets a ClearScreen procedure to be called on FormFeed characters}

Procedure SetSoundBellProc (SBP : SoundBellProc);
  {-Sets a SoundBell procedure to be called on Bell characters}

Function AnsiGotoXY (X, Y: Word): String;
Function AnsiUp (Lines: Word): String;
Function AnsiDown (Lines: Word): String;
Function AnsiRight (Cols: Word): String;
Function AnsiLeft (Cols: Word): String;
Function AnsiColor (Fg, Bg: Integer): String;
Function AnsiLength (S: String): Word;

Implementation

Type
  {Token types}
  ParserType = (GotNone, GotEscape, GotBracket, GotSemiColon,
  GotParm, GotCommand);

Const
  {Special parser characters}
  Escape = #27;
  LeftBracket = #91;
  Semicolon = #59;
  LineFeed = #10;
  FormFeed = #12;
  BellChar = #07;
  EqualSign = #61;
  QuestionMark = #63;

  {Convenient character constants (and aliases)}
  cNul = #0;
  cSoh = #1;
  cStx = #2;
  cEtx = #3;
  cEot = #4;
  cEnq = #5;
  cAck = #6;
  cBel = #7;
  cBS  = #8;
  cTab = #9;
  cLF  = #10;
  cVT  = #11;
  cFF  = #12;
  cCR  = #13;
  cSO  = #14;
  cSI  = #15;
  cDle = #16;
  cDC1 = #17;       cXon  = #17;
  cDC2 = #18;
  cDC3 = #19;       cXoff = #19;
  cDC4 = #20;
  cNak = #21;
  cSyn = #22;
  cEtb = #23;
  cCan = #24;
  cEM  = #25;
  cSub = #26;
  cEsc = #27;
  cFS  = #28;
  cGS  = #29;
  cRS  = #30;
  cUS  = #31;

  {For sizing parser}
  MaxQueueChars = 10;
  MaxParms = 5;

  {For sizing the screen}
  AnsiWidth : Word = 80;
  AnsiHeight : Word = 25;

  {For saving TextAttr states}
  Inverse : Boolean = False;
  Intense : Boolean = False;
  BlinkOn : Boolean = False;

  {For saving and restoring the cursor state}
  SaveX : Byte = 1;
  SaveY : Byte = 1;

Var
  {For saving invalid escape sequences}
  SaveCharQueue : Array [1..MaxQueueChars] Of Char;
  QTail : Byte;

  {For collecting and converting parameters}
  Parms : Array [1..MaxParms] Of String [5];
  ParmInt : Array [1..MaxParms] Of Integer;
  ParmDefault : Array [1..MaxParms] Of Boolean;
  ParmIndex : Byte;

  {Current token}
  ParserState : ParserType;

  {User hooks}
  ClearScreen    : ClearScreenProc;
  SoundBell      : SoundBellProc;

  Bold, TruncateLines   : Boolean;


Procedure WriteStringAnsi (S : String);
  {-Writes S (and handles ANSI escape sequences)}
Var
  I : Byte;
Begin
  For I := 1 To Length (S) Do
    WriteCharAnsi (S [I] );
End;

Procedure InitParser;
  {-Initialize parser for next ansi sequence}
Var
  I : Byte;
Begin
  QTail := 0;
  ParmIndex := 1;
  For I := 1 To MaxParms Do Begin
    Parms [I] := '';
    ParmDefault [I] := False;
  End;
  ParserState := GotNone;
End;

Procedure PushChar (C : Char);
  {-Push C into the saved char queue}
Begin
  If QTail < MaxQueueChars Then Begin
    Inc (QTail);
    SaveCharQueue [QTail] := C;
  End;
End;

Function HeadChar (Var C : Char) : Boolean;
  {-Returns the first character on the saved stack and moves the rest down}
Begin
  If QTail > 0 Then Begin
    C := SaveCharQueue [1];
    HeadChar := True;
    Dec (QTail);
    Move (SaveCharQueue [2], SaveCharQueue [1], QTail);
  End Else
    HeadChar := False;
End;

Procedure BuildParm (C : Char);
  {-Gets the next character of the current parameter}
Begin
  Parms [ParmIndex] := Parms [ParmIndex] + C;
End;

Procedure ConvertParms (C : Char);
  {-Convert the parms into integers}
Var
  I       : Integer;
  Code    : {$IFNDEF OS2} Integer; {$ELSE} LongInt; {$ENDIF}
Begin
  For I := 1 To MaxParms Do Begin
    Val (Parms [I], ParmInt [I], Code);
    If Code <> 0 Then Begin
      ParmInt [I] := 1;
      ParmDefault [I] := True;
    End;
  End;
  If ParmDefault [1] And (C In ['J', 'K'] ) Then
    {Change!!!, lines commented}
    {If UseVT100Mode Then}
      ParmInt [1] := 0;
    {Else
      ParmInt [1] := 2;}
  If (ParmInt [1] = 0) And (C In ['A', 'B', 'C', 'D'] ) Then
    ParmInt [1] := 1;
  If (C = 'm') And ParmDefault [1] Then                               {!!.02}
    ParmInt [1] := 0;                                                 {!!.02}
End;

{!!.02}
Procedure ClearEndOfLine;
  {-Clear to the end of the line}
Begin
  {Un-invert TextAttr before clearing}
  If Inverse Then
    TextAttr := (TextAttr ShL 4) Or (TextAttr ShR 4);

  ClrEol;

  {Restore inverted TextAttr}
  If Inverse Then
    TextAttr := (TextAttr ShL 4) Or (TextAttr ShR 4);

  SetCrtColor;
End;

Procedure ClearPart (X1, Y1, X2, Y2 : Integer);
  {-Clear from X1, Y1 to X2, Y2}
Var
  Row : Integer;
  SaveX, SaveY : Word;

Procedure ClearRow (X1, X2 : Integer);
  Var
    I : Integer;
  Begin
    GotoXY (X1, WhereY);
    If X2 = AnsiWidth Then ClrEol Else
    For I := X1 To X2 Do Write (' ');
  End;

Begin
  {Save cursor position}
  SaveX := WhereX;
  SaveY := WhereY;
  GotoXY (X1, Y1);

  {Un-invert TextAttr before clearing}                               {!!.02}
  If Inverse Then                                                    {!!.02}
    TextAttr := (TextAttr ShL 4) Or (TextAttr ShR 4);                {!!.02}

  SetCrtColor;

  If Y1 = Y2 Then
    ClearRow (X1, X2)
  Else Begin
    ClearRow (X1, AnsiWidth);
    If Y1 + 1 <= Y2 - 1 Then
    For Row := Y1 + 1 To Y2 - 1 Do
    Begin
      GotoXY (1, Row);
      ClearRow (1, AnsiWidth);
    End;

    GotoXY (1, Y2);
    ClearRow (1, X2);
  End;

  GotoXY (SaveX, SaveY);

  {Restore inverted TextAttr}                                        {!!.02}
  If Inverse Then                                                    {!!.02}
    TextAttr := (TextAttr ShL 4) Or (TextAttr ShR 4);                {!!.02}

  SetCrtColor;
End;

Procedure GotoXYCheck (X, Y : Integer);
  {-GotoXY that checks against negative numbers}
Begin
  If X < 1 Then X := 1;
  If Y < 1 Then Y := 1;
  GotoXY (X, Y);
End;

Procedure ProcessCommand (C : Char);
  {-Process the current command}
Var
  I, TextFg, TextBk : Byte;

Begin
  {Convert parameter strings to integers (and assign defaults)}
  ConvertParms (C);

  {Act on the accumulated parameters}
  Case C Of
    'f',  {HVP - horizontal and vertical position}
    'H' : {CUP - cursor position}
           GotoXYCheck (ParmInt [2], ParmInt [1] );

    'A' : {CUU - cursor up}
           GotoXYCheck (WhereX, WhereY - ParmInt [1] );

    'B' : {CUD - cursor down}
           GotoXYCheck (WhereX, WhereY + ParmInt [1] );

    'C' : {CUF - cursor forward}
           GotoXYCheck (WhereX + ParmInt [1], WhereY);

    'D' : {CUB - cursor back}
           GotoXYCheck (WhereX - ParmInt [1], WhereY);

    'J' : {ED - erase display}
           Case ParmInt [1] Of
             0 : ClearPart (WhereX, WhereY, AnsiWidth, AnsiHeight);
             1 : ClearPart (1, 1, WhereX, WhereY);
             2 : ClearScreen;
           End;

    'K' : {EL - erase in line}
          Case ParmInt [1] Of
            0 : ClearEndOfLine;                                        {!!.02}
            1 : ClearPart (1, WhereY, WhereX, WhereY);
            2 : ClearPart (1, WhereY, AnsiWidth, WhereY);
          End;

    'l',
    'm' : {SGR - set graphics rendition (set background color)}
          Begin
            For I := 1 To ParmIndex Do
            Begin
              If Inverse Then
                {Restore inverted TextAttr before continuing}
                TextAttr := (TextAttr ShL 4) Or (TextAttr ShR 4);

              {Separate out the forground and background bits}
              TextFg := TextAttr And $0F;
              TextBk := TextAttr And $F0;

              {Process the color command}
              Case ParmInt [I] Of
                0  : Begin
                       TextAttr := $07;                {White on black}
                       Inverse := False;
                       Intense := False;
                       BlinkOn := False;
                     End;
                1  : Intense  := True;               {Set intense bit later}
                4  : Intense  := True;               {Subst intense for underline}
              5, 6 : BlinkOn  := True;               {Set blinking on}
                7  : Inverse  := True;               {Invert TextAttr later}
                8  : TextAttr := $00;                {Invisible}
                27 : Inverse  := False;              {Stop inverting TextAttr}
                30 : TextAttr := TextBk Or $00;      {Black foreground}
                31 : TextAttr := TextBk Or $04;      {Red foreground}
                32 : TextAttr := TextBk Or $02;      {Green foreground}
                33 : TextAttr := TextBk Or $06;      {Yellow forground}
                34 : TextAttr := TextBk Or $01;      {Blue foreground}
                35 : TextAttr := TextBk Or $05;      {Magenta foreground}
                36 : TextAttr := TextBk Or $03;      {Cyan foreground}
                37 : TextAttr := TextBk Or $07;      {White foreground}
                40 : TextAttr := TextFg;             {Black background}
                41 : TextAttr := TextFg Or $40;      {Red background}
                42 : TextAttr := TextFg Or $20;      {Green background}
                43 : TextAttr := TextFg Or $60;      {Yellow background}
                44 : TextAttr := TextFg Or $10;      {Blue background}
                45 : TextAttr := TextFg Or $50;      {Magenta background}
                46 : TextAttr := TextFg Or $30;      {Cyan background}
                47 : TextAttr := TextFg Or $70;      {White background}
              End;

              {Fix up TextAttr for inverse and intense}
              If Inverse Then Begin
                TextAttr := (TextAttr ShL 4) Or (TextAttr ShR 4);
                If MaskBlinkOnInverse Then
                  TextAttr := TextAttr And $7F;
              End;
              If Intense Then
                TextAttr := TextAttr Or $08;
              If BlinkOn Then
                TextAttr := TextAttr Or $80;
            End;

            SetCrtColor;
          End;

    's' : {SCP - save cursor position}
          Begin
            SaveX := WhereX;
            SaveY := WhereY;
          End;

    'u' : {RCP - restore cursor position}
          GotoXY (SaveX, SaveY);

    Else
      {Invalid esc sequence - display all the characters accumulated so far}
      While HeadChar (C) Do
      Case C Of
        FormFeed : ClearScreen;
        BellChar : If ToBell Then SoundBell;
      Else
        Write (C);
      End;
  End;
End;

Procedure WriteCharAnsi (C : Char);
  {-Writes C (and handles ANSI sequences)}
Var
  SaveAttr : Word;
Label
  ErrorExit;
Begin
  PushChar (C);

  Case ParserState Of
    GotNone : {Not in an ANSI sequence}
              Begin
                If C = Escape Then
                  ParserState := GotEscape
                Else
                  Case C Of
                    cCR      : Write (cCR);

                    LineFeed : {Clear background before scrolling window}
                               Begin
                                 SaveAttr := TextAttr;
                                 TextAttr := TextAttr And $0F;
                                 If WhereY = Hi (WindMax)+1 Then Dec (SaveY);
                               {$IFDEF WIN32}
                                 SetCrtColor;
                               {$ENDIF}
                                 Write (C);
                                 TextAttr := SaveAttr;
                               {$IFDEF WIN32}
                                 SetCrtColor;
                               {$ENDIF}
                               End;
                    FormFeed : {Special case - clear screen on formfeed}
                                 ClearScreen;
                    BellChar : {Special case - ring bell on bell character}
                                 SoundBell;
                    Else       {Normal character, just write it}
                      If (WhereX <> {$IFNDEF WIN32} Lo (WindMax) + 1 {$ELSE} 80 {$ENDIF}) Then
                      Begin
                        If (WhereY >= {$IFNDEF WIN32} Hi (WindMax) + 1 {$ELSE} 25 {$ENDIF}) Then Dec (SaveY); {!!!}
                        Dec (SaveY);
                        Write (C);
                      End Else
                      Case C Of
                        cCR : Write (cCR);
                      Else
                        Write (C);
                        If InhibitAutoLF Then
                          GotoXYCheck ({$IFNDEF WIN32} Lo (WindMax) + 1 {$ELSE} 79 {$ENDIF}, WhereY - 1);
                      End;
                  End;
                {Fast reinit of parser}
                QTail := 0;
              End;

    GotEscape : {Last character was escape -- need [}
                  If C = LeftBracket Then
                    ParserState := GotBracket
                  Else
                    Goto ErrorExit;

    GotParm,
    GotBracket,
    GotSemicolon : {Need parameter char, semicolon, equalsign or command}
                     If (C >= #48) And (C <= #57) Then Begin
                       {It's a number, go add it to the current parameter}
                       BuildParm (C);
                       ParserState := GotParm;
                     End Else If (C = EqualSign) Or (C = QuestionMark) Then
      {just ignore it}
    Else If C = Semicolon Then
      {It's a semicolon, prepare for next parameter}
      If ParserState = GotSemicolon Then
        {goto ErrorExit}                                           {!!.02}
      Else Begin
        ParserState := GotSemicolon;
        Inc (ParmIndex);
        If ParmIndex > MaxParms Then
          Goto ErrorExit;
      End
    Else Begin
      {Must be a command, go process it}
      ProcessCommand (C);
      InitParser;
    End;
  End;
  Exit;

  ErrorExit:
  {Invalid escape sequence -- display all the characters accumulated so far}
  While HeadChar (C) Do Write (C);
  InitParser;
End;

Procedure DefClearScreen;
Begin
  ClrScr;
End;

Procedure DefSoundBell;
Begin
{$IFNDEF WIN32}
  PlaySound (220, 200);
{$ELSE}
  Beep;
{$ENDIF}
End;

Procedure SetClearScreenProc (CSP : ClearScreenProc);
  {-Sets a ClearScreen procedure to be called on FormFeed characters}
Begin
  ClearScreen := CSP;
End;

Procedure SetSoundBellProc (SBP : SoundBellProc);
  {-Sets a SoundBell procedure to be called on Bell characters}
Begin
  SoundBell := SBP;
End;

Function AnsiGotoXY (X, Y: Word): String;
Var
  XStr, YStr: String;

Begin
  Str (X, XStr);
  Str (Y, YStr);
  ANSIGotoXY := #27'[' + YStr + ';' + XStr + 'H';
End;

Function AnsiUp (Lines: Word): String;
Var
  LinesStr: String;

Begin
  Str (Lines, LinesStr);
  ANSIUp := #27'[' + LinesStr + 'A';
End;

Function AnsiDown (Lines: Word): String;
Var
  LinesStr: String;

Begin
  Str (Lines, LinesStr);
  ANSIDown := #27'[' + LinesStr + 'B';
End;

Function AnsiRight (Cols: Word): String;
Var
  ColsStr : String;

Begin
  Str (Cols, ColsStr);
  ANSIRight := #27'[' + ColsStr + 'C';
End;

Function AnsiLeft (Cols: Word): String;
Var
  ColsStr: String;

Begin
  Str (Cols, ColsStr);
  ANSILeft := #27'[' + ColsStr + 'D';
End;

Function AnsiColor (Fg, Bg: Integer): String;
Var
  FgStr, BgStr, Temp: String;

Begin
  Str (ColorArray [Fg Mod 8] + 30, FgStr);
  Str (ColorArray [Bg Mod 8] + 40, BgStr);
  Temp := #27'[';
  If Bg > 7 Then Temp := Temp + '5;'
            Else Temp := Temp + '0;';
  If Fg > 7 Then Temp := Temp + '1;'
            Else Temp := Temp + '2;';
  ANSIColor := Temp + FgStr + ';' + BgStr + 'm';
End;

Function AnsiLength (S: String): Word;
Var
  SaveX, SaveY: Byte;
  MusicPos: Integer;
  LenSize: Word;

Procedure ProcessEsc;
Var
  DeleteNum : Integer;
  ts : String [5];
  Num : Array [0..10] Of ShortInt;
  Color : Integer;

Label
  loop;

Procedure GetNum (CX : Byte);
Var
  Code : SysInt;

Begin
  ts := '';
  While (s [1] In ['0'..'9'] ) And (Length (s) > 0) Do
  Begin
    ts := ts + s [1];
    Delete (s, 1, 1);
  End;
  Val (ts, Num [CX], Code)
End;

Begin
  If s [2] <> '[' Then Exit;
  Delete (s, 1, 2);
  If (UpCase (s [1] ) = 'M') And (UpCase (s [2] ) In ['F', 'B', #32] ) Then
  Begin
    Delete (s, 1, 2);
    MusicPos := Pos (#14, s);
    DeleteNum := MusicPos;
    Goto Loop;
  End;

  FillChar (Num, SizeOf (Num), #0);
  GetNum (0);
  DeleteNum := 1;
  While (s [1] = ';') And (DeleteNum < 11) Do
  Begin
    Delete (s, 1, 1);
    GetNum (DeleteNum);
    DeleteNum  := DeleteNum + 1;
  End;

  Case UpCase (s [1] ) Of
    'A' :
         Begin
           If Num [0] = 0 Then Num [0] := 1;
           While Num [0] > 0 Do
           Begin
             GotoXY (WhereX, WhereY - 1);
             Num [0] := Num [0] - 1;
           End;
           DeleteNum := 1;
         End;
    'B' :
         Begin
           If Num [0] = 0 Then Num [0] := 1;
           While Num [0] > 0 Do
           Begin
             GotoXY (WhereX, WhereY + 1);
             Num [0] := Num [0] - 1;
           End;
           DeleteNum := 1;
         End;
    'C' :
         Begin
           If Num [0] = 0 Then Num [0] := 1;
           While Num [0] > 0 Do
           Begin
             GotoXY (WhereX + 1, WhereY);
             Num [0] := Num [0] - 1;
           End;
           DeleteNum := 1;
         End;
    'D' :
         Begin
           If Num [0] = 0 Then Num [0] := 1;
           While Num [0] > 0 Do
           Begin
             GotoXY (WhereX - 1, WhereY);
             Num [0] := Num [0] - 1;
           End;
           DeleteNum := 1;
         End;
    'H',
    'F' :
         Begin
           If (Num [0] = 0) Then Num [0] := 1;
           If (Num [1] = 0) Then Num [1] := 1;
           GotoXY (Num [1], Num [0] );
           DeleteNum := 1;
         End;
    'S' :
         Begin
           {position}
           SaveX := WhereX;
           SaveY := WhereY;
           DeleteNum := 1;
         End;
    'U' :
         Begin
           {saved position}
           GotoXY (SaveX, SaveY);
           DeleteNum := 1;
         End;
    'J' :
         Begin
           If Num [0] = 2 Then ClrScr;
           DeleteNum := 1;
         End;
    'K' :
         Begin
           {$IFNDEF OS2}
           {cursor position}
           ClrEol;
           {$ENDIF}
           {to end of line}
           DeleteNum := 1;
         End;
    'M' :
         Begin
           {colors and}
           DeleteNum := 0;
           {attributes}

           While (Num [DeleteNum] <> 0) Or (DeleteNum = 0) Do
           Begin
             Case Num [DeleteNum] Of
               0 : Begin
                     TextAttr := 7;
                     Bold := False;
                   End;
               1 : Begin
                     Bold := True;
                   {$IFNDEF WIN32}
                     HighVideo;
                   {$ENDIF}
                   End;
               5 : TextAttr := TextAttr Or Blink;
               7 : TextAttr := ((TextAttr And $07) ShL 4) + ((TextAttr And $70) ShR 4);
               8 : TextAttr := 0;
          30..37 : Begin
                     Color := ColorArray [Num [DeleteNum]- 30];
                     If Bold Then Color := Color + 8;
                     TextColor ((TextAttr And Blink) + Color);
                     {| Added "textattr and blink" to preserve blink status. DDA|}
                   End;
               {general backgrounds}
               40..47 : TextBackground (ColorArray [Num [DeleteNum] - 40]);
             End;
             DeleteNum := DeleteNum + 1;
           End;

         {$IFDEF WIN32}
           SetCrtColor;
         {$ENDIF}
           DeleteNum := 1;
         End;
    '=',
    '?' :
         Begin
           Delete (s, 1, 1);
           GetNum (0);
           If UpCase (s [1] ) = 'L' Then If Num [0] = 7 Then TruncateLines := True;
           DeleteNum := 1;
         End;
  End;
  loop:       Delete (s, 1, DeleteNum);
End;

Begin
  LenSize := 0;
  While Length (S) > 0 Do
  Begin
    If s [1] = #27 Then ProcessEsc Else
    Begin
      LenSize := LenSize + 1;
      Delete (s, 1, 1);
    End;
  End;
  AnsiLength := LenSize;
End;

Begin
  InitParser;
  SoundBell := DefSoundBell;
  ClearScreen := DefClearScreen;
End.