POINT Software Programming/PPROG1.ISO/pascal/visionix/test/tcrt.pas

Pascal/Delphi Source File | 1993-12-29 | 8.9 KB | 561 lines

program tcrt;

uses

  vtypesu,
  vstringu,
  vgenu,
  voutu,
  vserlu,
  vseru,
  vserhu,
  vfosu,
  vcrtu;

{────────────────────────────────────────────────────────────────────────────}


Type

  TWackyParams = RECORD
    LookFor    : CHAR;
    ReplaceWith: CHAR;
  END;

  PWackyParams = ^TWackyParams;

Var

  serh : TSerHandle;

{────────────────────────────────────────────────────────────────────────────}

Procedure SetupSer( Port : BYTE;
                    Baud : WORD         );

Var

  err : word;
  cp  : TCommParam;

BEGIN

  { Create new serial channel }

  Err := VSerChanNew( 0,
                      FosSerDriverProc,
                      Port,                    { comport }
                      0,
                      0,
                      SerH );

  If Err<>0 Then
  BEGIN
    Writeln(' VserChannew = ',err );
    Halt( 69 );
  END;

  { activate/initialize the channel }

  CP.BaudRate   := Baud;
  CP.Parity     := 'N';
  CP.DataBits   := 8;
  CP.StopBits   := 1;

  Err := VSerChanActivate( SerH, @CP );

  If Err<>0 Then
  BEGIN
    Writeln(' VserChanActivate = ',err );
    Halt( 69 );
  END;

  VSerAnsiOutSubChanNew( Serh,
                         0,
                         'SERANSI',
                         CrtOCH,
                         TRUE        );


  VSerPurgeOutBuff( Serh );
  VSerPurgeInBuff( Serh );

  TextColors( white, black );

  ClrScr;

  WriteLn('VisionTools CRT Tester; Version 0.9');
  WriteLn;
  Write('Press % key to start the show...');

  VSerWaitCh( Serh, '%', 30000, FALSE );

END;

{────────────────────────────────────────────────────────────────────────────}

Procedure WaitForKey;

BEGIN

  ReadKey;

END;

{────────────────────────────────────────────────────────────────────────────}


Procedure TestClrScr;

Var

  z : INTEGER;

BEGIN

  For Z := 0 to 15 do
  BEGIN

    TextBackGround( Z );

    ClrScr;

    Delay( 500 );

  END;

  WaitForKey;

END;


{────────────────────────────────────────────────────────────────────────────}


Procedure TestTextColor;

Var

  Z : INTEGER;

BEGIN

  TextBackGround( Black );

  ClrScr;

  Z:=0;

  Repeat
    TextColor( Z );
    {WriteLn('Hello, world!');}
    Write('Hello, world! ');

    Inc(Z);
    If Z>15 Then
      Z:=0;

  Until KeyPressed;

(*
  For Z := 0 to 100 Do
  BEGIN
    TextColor( Z MOD 16 );
    WriteLn('Hello, World!');
  END;
*)


  WaitForKey;

END;

{────────────────────────────────────────────────────────────────────────────}


Procedure TestGotoAndWhereXY;

var

  x,y : BYTE;
  W   : INTEGER;
  Z   : INTEGER;

BEGIN

  For W := 1 to 5 Do
  BEGIN

    Window( w,w, 80,24 );

    TextBackGround( W+1 );
    TextColor( BLACK );

    ClrScr;

    For Z := 1 to 15 Do
    BEGIN
      GotoXY( Z, Z );
      X:=WhereX;
      Y:=WhereY;
      Write( X,',',Y,' (',Z,',',Z,')' );
    END;

    WaitForKey;

  END;

END;

{────────────────────────────────────────────────────────────────────────────}


Procedure TestScroll;

var

  x,y : BYTE;
  Z   : INTEGER;

  Cl  : STRING;

BEGIN

  CL := '1234567890';

  TextBackGround( white );
  TextColor( Red );

  WindowScreen;

  ClrScr;

  Z := 0;

  Write('12345678901234567890123456789012345678901234567890123456789012345678901234567890');
  window(5,2,75,11);
  Textbackground( black );
  clrscr;

  Repeat
    Inc( Z );
    If Z>Length(CL) Then
      Z:=1;

    textbackground(z);
    Write(RepeatString( CL[Z],30 ) );

    x:=wherex;
    y:=wherey;
    gotoxy(1,1);
    clreol;
    write( 'x=',x,' y=',y );
    gotoxy(x,y);

  Until ReadKey=#27;

END;

{────────────────────────────────────────────────────────────────────────────}


Procedure TestRegions;

Var

  r1 : POINTER;
  r2 : POINTER;

  x2,y2 : INTEGER;

BEGIN

  GetMem( R1, RegionMemQuery( 1 ,1,13,16 ) );
  GetMem( R2, RegionMemQuery( 20,1,32,16 ) );

  RegionRead( 1 ,1,13,16, R1 );

  Repeat

    x2 := random( 80-15 )+1;
    y2 := random( 50-12 )+1;

    RegionRead(  X2,Y2, X2+12, Y2+15, R2 );

    RegionWrite( X2,Y2, X2+12, Y2+15, R1 );

    Delay( 5 );

    RegionWrite( X2,Y2, X2+12, Y2+15, R2 );

  Until KeyPressed;

  ReadKey;
  WaitForKey;

  FreeMem( r1, RegionmemQuery( 1 ,1,13,16 ) );
  FreeMem( r2, RegionmemQuery( 20,1,32,16 ) );

END;


Procedure TestRegions2;

Var

  r1 : POINTER;
  r2 : POINTER;

  x2,y2 : INTEGER;

BEGIN

  GetMem( R1, RegionMemQuery( 5,5,75,20 ) );

  RegionRead( 5,5,75,20, R1 );

  WaitForKey;

  RegionWrite( 5,5,75,20, R1 );

  WaitForKey;

  FreeMem( r1, RegionmemQuery( 5,5,75,20 ) );

END;




{────────────────────────────────────────────────────────────────────────────}


Procedure WackyFilter(       ODP            : POutDriverPacket ); FAR;

Type


  TCharBuff = Array[1..32768] of CHAR;
  PCharBuff = ^TCharBuff;

  TWackyFilterIData = Record

    Off        : WORD;
    Name       : TProcName;
    LookFor    : CHAR;
    ReplaceWith: CHAR;

  END;  { TCRTOutDriverIData }

  PWackyFilterIData = ^TWackyFilterIData;

  {----}

Var
  IData      : PWackyFilterIData;

  Z          : INTEGER;


BEGIN  { CRTOutDriverProc }

  IData := ODP^.ID;

  If ODP^.Status = 0 Then
  BEGIN

    Case ODP^.Func Of

      ODF_DriverNew:
      BEGIN

        {-----------------------------}
        { are they telling me to new? }
        {-----------------------------}

        IF @ODP^.OutDriverProc = @WackyFilter Then
        BEGIN

          {-------------------------}
          { Get a new Instance Data }
          { master node.            }
          {-------------------------}

          New( Idata );

          IData^.Off := 0;

          IData^.Name := ODP^.Name^;

          If Pointer(ODP^.DriverParam1)<>NIL Then
          BEGIN
            IData^.LookFor     := PWackyParams( ODP^.DriverParam1 )^.LookFor;
            IData^.ReplaceWith := PWackyParams( ODP^.DriverParam1 )^.ReplaceWith;
          END
          ELSE
          BEGIN
            IData^.LookFor     := ' ';
            IData^.replacewith := ' ';
          END;

          ODP^.Status    := ODS_Install+ODS_Changed;
          ODP^.ID        := IData;

        END; { If ODP^.OutDriverProc --> Us }

      END; { ODF_DriverNew }

      {----}

      ODF_DriverOff:
      BEGIN

        If ODP^.Name^ = IData^.Name Then
        BEGIN

          Inc( Idata^.Off );

        END;  { If ODP^.Name^ }

      END;  { ODF_DriverOff }

      {----}

      ODF_DriverOn:
      BEGIN

        If ODP^.Name^ = IData^.Name Then
        BEGIN

          If Idata^.Off <> 0 Then
            Dec( Idata^.Off );

        END;  { ODP^.Name^ }

      END;  { ODF_DriverOn }

      {----}

      ODF_DriverDispose:
      BEGIN

        If ODP^.Name^ = IData^.Name Then
        BEGIN

          {RemoveFromOutDriverStack }

          Dispose( IData );

        END;  { If ODP^.Name^ }

      END;  { ODF_DriverDispose }

      {----}

      ODF_WriteChar:
      BEGIN

        If ODP^.Ch=IData^.LookFor Then
          ODP^.Ch := IData^.ReplaceWith;

      END;  { ODF_WriteChar }

      {----}

      ODF_WriteBlock:
      BEGIN

        For Z:=1 to ODP^.Size Do
        BEGIN

          If PCharBuff( ODP^.BUFF )^[Z]=Idata^.LookFor Then
            PCharBuff( ODP^.BUFF )^[Z] :=Idata^.ReplaceWith;

        END; { For Z }


      END;  { ODF_WriteBlock }

      {----}

    Else { Else Case }

    END;  { Case ODP^.Func }

  END; { If ODP^.Status = 0 }

  CallNextDriver( ODP );

END;  { CRTOutDriverProc }


{────────────────────────────────────────────────────────────────────────────}


Procedure TestInstallFilters;

Var

  Wackyp : TWackyParams;


BEGIN

  wackyp.lookfor := 'H';
  wackyp.replacewith := 'Z';

  VOutFilterAttach( CrtOCH,
                    0,
                    'WACKY!',
                    'Bx00VMEM',
                    WackyFilter,
                    longint(@wackyp),0,0         );

  wackyp.lookfor := '!';
  wackyp.replacewith := '?';

  VOutFilterAttach( CrtOCH,
                    0,
                    'WACKIER!',
                    'Bx00VMEM',
                    WackyFilter,
                    longint(@wackyp),0,0         );


END;


{────────────────────────────────────────────────────────────────────────────}
{────────────────────────────────────────────────────────────────────────────}
{────────────────────────────────────────────────────────────────────────────}


begin

  WriteLn('VisionTools CRT tester; version 0.9');
  WriteLn;

{  SetupSer( 2 );  } { uncomment this to send output to FOSSIL PORT #2 }

  TestClrScr;

  TestGotoAndWhereXY;

  TestTextColor;

  TestScroll;

  TestInstallFilters;

  TestTextColor;

  WindowScreen;

  TestTextColor;

  TestRegions2;

  TestRegions;

end.