dxansi.pas

Well known and usefull component for delphi 7

Unit DXAnsi;

Interface

///////////////////////////////////////////////////////////////////////////////
//         Unit: DXANSI
//       Author: G.E. Ozz Nixon Jr. ([e-mail])
// ========================================================================
// Source Owner: DX, Inc. 1995-2002
//    Copyright: All code is the property of DX, Inc. Licensed for
//               resell by Brain Patchwork DX (tm) and part of the
//               DX (r) product lines, which are (c) 1999-2002
//               DX, Inc. Source may not be distributed without
//               written permission from both Brain Patchwork DX,
//               and DX, Inc.
//      License: (Reminder), None of this code can be added to other
//               developer products without permission. This includes
//               but not limited to DCU's, DCP's, DLL's, OCX's, or
//               any other form of merging our technologies. All of
//               your products released to a public consumer be it
//               shareware, freeware, commercial, etc. must contain a
//               license notification somewhere visible in the
//               application.
//               Example is Internet Explorer - Help->About screen
//               shows the licensed code contained in the application.
// Code Version: (3rd Generation Code)
// ========================================================================
//  Description: ANSI Rendering to DXCRT Console Screen
// ========================================================================
///////////////////////////////////////////////////////////////////////////////

Uses
   Classes;

Const
  DXAnsiHandlerMaxParms = 200;

Type
  TDX_ColorChange = procedure(NewColor:Byte) of object;
  TDX_ClearScreen = procedure of object;
  TDX_ClearToEOL = procedure of object;
  TDX_InsertLine = procedure of object;
  TDX_DeleteLine = procedure of object;
  TDX_GetRow = procedure(Var Where_Y:Byte) of object;
  TDX_GetCol = procedure(Var Where_X:Byte) of object;
  TDX_SetRowCol = procedure(Where_X,Where_Y:Byte) of object;
  TDX_Write = procedure(Ch:Char) of object;
  TDXAnsiHandler = class(TComponent)
  private
     AvState: Word;            {0=normal, 1=esc, 2=esc[}        {Ansi}
                               {5=^Y, 6=^Y#, 7=^V, 8=^V^A}      {Avatar}
                               {9=^V^H 10=^V^H#}
                               {11=Collect Parameters}
     AvAttr: Byte;
     AnsiParm: Array [1..DXAnsiHandlerMaxParms] of Byte;
     AnsiParmNo: Byte;
     SaveX: Byte;
     SaveY: Byte;
     InsertMode: Boolean;
     CommandType: Word;
     RemainingParms: Byte;
     RepCount: Byte;
     fOnColorChange:TDX_ColorChange;
     fClearScreen:TDX_ClearScreen;
     fClearToEOL:TDX_ClearToEOL;
     fGetWhereY:TDX_GetRow;
     fGetWhereX:TDX_GetCol;
     fSetXY:TDX_SetRowCol;
     fInsertLine:TDX_InsertLine;
     fDeleteLine:TDX_DeleteLine;
     fOnWrite:TDX_Write;
     fTextAttr:Byte;
  protected
    Procedure ColorParm(Parm:Byte);
    Procedure ProcCtl(ch:Char);
    Procedure Accum(ch: Char);
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    Function  InAvatar:Boolean;
    Function  AnsiColor(Fore:Byte;Back:Byte):String;
    Function  AnsiAttr(AA:Byte):String;
    Function  AnsiAttrDiff(OldA:Byte;NewA:Byte):String;
    Procedure ShowEmulatorChar(ch:Char);
    Procedure ShowEmulatorStr(S:String);
    Function  CvtColor(colr:Byte):String;
    Procedure AVReset;
  published
    Property OnColorChange:TDX_ColorChange read fOnColorChange write fOnColorChange;
    Property OnClearScreen:TDX_ClearScreen read fClearScreen write fClearScreen;
    Property OnClearToEOL:TDX_ClearToEOL read fClearToEOL write fClearToEOL;
    Property OnGetWhereY:TDX_GetRow read fGetWhereY write fGetWhereY;
    Property OnGetWhereX:TDX_GetCol read fGetWhereX write fGetWhereX;
    Property OnSetXY:TDX_SetRowCol read fSetXY write fSetXY;
    Property OnLineInsert:TDX_InsertLine read fInsertLine write fInsertLine;
    Property OnLineDelete:TDX_DeleteLine read fDeleteLine write fDeleteLine;
    Property OnWrite:TDX_Write read fOnWrite write fOnWrite;
  end;

Implementation

Uses
   DXString,
   SysUtils;

Const
  ControlCh: Set of Char = ['A','B','C','D','f','s','u','H','J','K','m',';','M','L'];

constructor TDXAnsiHandler.Create(AOwner:TComponent);
Begin
   inherited Create(AOwner);
   SaveX := 0;
   SaveY := 0;
   AvState := 0;
   AvAttr := 3;
   fTextAttr := $07;
   InsertMode := False;
End;

destructor TDXAnsiHandler.Destroy;
Begin
   inherited Destroy;
End;

Function TDXAnsiHandler.InAvatar: Boolean;
Begin
   InAvatar := (AvState > 0);
End;

Function TDXAnsiHandler.CvtColor(colr:Byte):String;
Begin
   Colr := Colr mod 8;
   Case Colr of
      0,2,5,7: cvtcolor:=IntToStr(Colr);
      1: cvtcolor := '4';
      3: cvtcolor := '6';
      4: cvtcolor := '1';
      6: cvtcolor := '3';
   End;
End;


Function TDXAnsiHandler.AnsiAttrDiff(OldA: Byte; NewA: Byte): String;
  Var
    DoReset: Boolean;
    DoBlink: Boolean;
    DoHigh: Boolean;
    DoFore: Boolean;
    DoBack: Boolean;
    TmpStr: String;

  Begin
  If OldA = NewA Then AnsiAttrDiff := ''
  Else
    Begin
    DoReset := ((OldA and $88) and (Not (NewA and $88))) <> 0;
    DoBlink := ((NewA and $80) <> 0) And (DoReset or (OldA and $80 = 0));
    DoHigh  := ((NewA and $08) <> 0) and (DoReset or (OldA and $08 = 0));
    DoFore  := (((NewA and $07) <> (OldA and $07)) or (DoReset and ((NewA and $07) <> 7)));
    DoBack  := (((NewA and $70) <> (OldA and $70)) or (DoReset and ((NewA and $70) <> 0)));
    TmpStr := #27 + '[';
    If DoReset Then
      TmpStr := TmpStr + '0;';
    If DoBlink Then
      TmpStr := TmpStr + '5;';
    If DoHigh Then
      TmpStr := TmpStr + '1;';
    If DoFore Then
      TmpStr := TmpStr + '3' + CvtColor(NewA and $07) + ';';
    If DoBack Then
      TmpStr := TmpStr + '4' + CvtColor((NewA shr 4) and $07) + ';';
    TmpStr[Length(TmpStr)] := 'm';
    AnsiAttrDiff := TmpStr;
    End;
  End;


Function TDXAnsiHandler.AnsiColor(Fore:Byte;Back:Byte):String;
  Var
    TempStr:    String;

  Begin
  TempStr := #027;
  TempStr := TempStr +'['+ '0;';
  If Fore > 7 Then
    Begin
    TempStr := TempStr + '1;';
    Fore := Fore - 8;
    End;
  If Back > 7 Then
    Begin
    TempStr := TempStr + '5;';
    Back := Back - 8;
    End;
  TempStr := TempStr + '3';
  TempStr := TempStr + CvtColor(Fore) + ';' + '4' + CvtColor(Back) + 'm';
  AnsiColor := TempStr;
  End;

Function TDXAnsiHandler.AnsiAttr(AA: Byte): String;
Begin
   AnsiAttr := AnsiColor(AA and $0f, AA shr 4);
End;

Procedure TDXAnsiHandler.AVReset;
Begin
  AvState := 0;
  AvAttr := 3;
  fTextAttr := AvAttr;
  If Assigned(fOnColorChange) then
     fOnColorChange(fTextAttr);
  If Assigned(fClearScreen) then
     fClearScreen;
  InsertMode := False;
End;

Procedure TDXAnsiHandler.ColorParm(Parm:Byte);
  Var
    Temp: Word;

  Begin
  Case parm of
    00: AvAttr := 7;
    01: AvAttr := AvAttr or $08;             {Hi intensity}
    04: AvAttr := (AvAttr and $F8) or 1;
    05: AvAttr := AvAttr or $80;             {Blink}
    07: Begin
        Temp := AvAttr and $77;
        AvAttr := (AvAttr and $88) or ((Temp shr 4) and $07);
        AvAttr := AvAttr or ((Temp shl 4) and $70);
        End;
    08: AvAttr := AvAttr and $88;      {black on black}
    30: AvAttr := (AvAttr and $F8) or 0;
    31: AvAttr := (AvAttr and $F8) or 4;
    32: AvAttr := (AvAttr and $F8) or 2;
    33: AvAttr := (AvAttr and $F8) or 6;
    34: AvAttr := (AvAttr and $F8) or 1;
    35: AvAttr := (AvAttr and $F8) or 5;
    36: AvAttr := (AvAttr and $F8) or 3;
    37: AvAttr := (AvAttr and $F8) or 7;
    40: AvAttr := (AvAttr and $8F) or (0 shl 4);
    41: AvAttr := (AvAttr and $8F) or (4 shl 4);
    42: AvAttr := (AvAttr and $8F) or (2 shl 4);
    43: AvAttr := (AvAttr and $8F) or (6 shl 4);
    44: AvAttr := (AvAttr and $8F) or (1 shl 4);
    45: AvAttr := (AvAttr and $8F) or (5 shl 4);
    46: AvAttr := (AvAttr and $8F) or (3 shl 4);
    47: AvAttr := (AvAttr and $8F) or (7 shl 4);
    End;
  End;

Procedure TDXAnsiHandler.ProcCtl(ch:Char);
  Var
    i:Word;
    a:Byte;
    b:Byte;

  Begin
  Case ch of
    ';': Begin
         Ansiparmno := Ansiparmno + 1;
         if Ansiparmno > 10 Then
           Ansiparmno := 10;
         End;
    'A': Begin
         If Ansiparm[1] = 0 Then
           Ansiparm[1] := 1;
         fGetWhereY(B);
         fgetWhereX(A);
         If AnsiParm[1]>B then B:=0
         Else Dec(B,AnsiParm[1]);
         fSetXY(A,B);
         AvState := 0;
         End;
    'B': Begin
         If Ansiparm[1] = 0 Then
           AnsiParm[1] := 1;
         fGetWhereY(B);
         fgetWhereX(A);
         fSetXY(A,B+AnsiParm[1]);
         AvState := 0;
         End;
    'C': Begin
         If Ansiparm[1] = 0 Then
           Ansiparm[1] := 1;
         fGetWhereY(B);
         fgetWhereX(A);
         fSetXY(A+AnsiParm[1],B);
         AvState := 0;
         End;
    'D': Begin
         If AnsiParm[1] = 0 Then
            AnsiParm[1] := 1;
         fGetWhereY(B);
         fgetWhereX(A);
         If AnsiParm[1]>A then A:=0
         Else Dec(A,AnsiParm[1]);
         fSetXY(A,B);
         AvState := 0;
         End;
    'H','f':
         Begin
         if Ansiparm[1] = 0 Then
           Ansiparm[1] := 1;
         If Ansiparm[2] = 0 Then
            Ansiparm[2] := 1;
         fSetXY(Ansiparm[2],Ansiparm[1]);
         AvState := 0;
         End;
    'J': Begin
         AvState := 0;
         If AnsiParm[1] = 2 Then
           Begin
           fTextAttr := AvAttr;
           if Assigned(fOnColorChange) then
              fOnColorChange(fTextAttr);
           If Assigned(fClearScreen) then
              fClearScreen;
           End;