PC-X 1998 March/pcx19_9803.iso/PC-XUSER/PC-XUSER.14/OOP/PCX_UTIL.PAS

Pascal/Delphi Source File | 1997-01-27 | 9.2 KB | 439 lines

{*******************************************************}
{                                                       }
{   PC-X User utility for Turbo Vision                  }
{   Copyright (c) 1997 By PC-X User and Bérczi László   }
{                                                       }
{   Portions Copyright (c) 1990 by Borland Int.         }
{*******************************************************}
{Last Edit: 1997 II 15. 21:00}
{$X+,V-,F+,O-,S+,Q-,G+}

unit PCX_Util;

INTERFACE
type
  PScreen = ^TScreen;                                      {  For Video   }
  TScreen = Array[1..25,1..80,1..2] of Byte;

  PChrData = ^TChrData;                                    {For NewCharsOn}
  TChrData = Array[0..4095] of Byte;

  PChrData16 = ^TChrData16;
  TChrData16 = Array[0..15] of Byte;

const
  IsPCXGraphCharsOn: Boolean = False;

var
  Screen: PScreen;



function  GetPrimaryAdapterType: Byte;
function  UCaseString(const S: String): String;
function  SearchForParameter(S: String): Boolean;

{Screen}
procedure SetXY(Col, Row: Byte); {asm}
procedure GetXY(var Col, Row: Byte); {asm}

procedure SetBackGroundIntensity(On: Boolean);
function  IsBackGroundIntensityOn: Boolean;

procedure GetScreen(var Kepernyo: TScreen);
procedure PutScreen(Kepernyo: TScreen);

{Char edit}
procedure NewCharOn(Dat: Pointer; Car, Fm: Word); {asm}
procedure NewCharsOn(CharSet: TChrData; Car, Fm, Count: Word);
procedure GetChar(Dat: Pointer; Car, Fm: Word); {asm}
procedure GetChars(var CharSets: TChrData; Car, FM , Count: Word);

procedure GetSaveableChars;
procedure PutSavedChars;

procedure PCX_Font; {Fonttable}
procedure SetPCXGraphChars(State: Boolean);

{Key}
procedure KeyStrokeToKeyboardBuffer(ASCII, ScanC: Byte); {asm} {ScanC: 0 if you don't care}

IMPLEMENTATION

var
  Temp2     : TChrData16;
  SavedFont : TChrData; { For NewCharsOn }
  Charset   : TChrData; {For external NewCharsOn()}
 { TempScreen: PScreen;
  TX, TY    : Byte;}


function  GetPrimaryAdapterType: Byte; Assembler;
asm
  mov ax,  1A00h
  int 10h
  mov al,  bl
end;

function  UCaseString(const S: String): String; Assembler;
asm
  push es
  push ds
  push di
  push si
  lds  si, S
  les  di, @Result
  mov  dl, Byte Ptr ds:[si]
  mov  Byte Ptr es:[di], dl
  xor  dh, dh
  xor  bx, bx
@Loop:
  inc  bx
  mov  al, Byte Ptr ds:[si+bx]
  cmp  al, 'a'
  jb   @Cont
  cmp  al, 'z'
  ja   @Cont
  sub  al, 'a' - 'A'
@Cont:
  mov  Byte Ptr es:[di+bx], al
  cmp  bx, dx
  jb   @Loop
  pop  si
  pop  di
  pop  ds
  pop  es
end;

function  SearchForParameter(S: String): Boolean;
var
  i    : Word;
  Found: Boolean;
begin
  i:=0;
  Found:=False;
  if ParamCount > 0 then
    while (ParamCount > i) and (Not Found) do
    begin
      Inc(i);
      if UCaseString(ParamStr(i)) = UCaseString(S) then Found:=True;
    end;
  SearchForParameter:=Found;
end;

{Screen}
procedure SetXY(Col, Row: Byte); Assembler;
asm
  MOV  AH,02h
  XOR  BH, BH
  MOV  DH, Row
  DEC  DH
  MOV  DL, COL
  DEC  DL
  PUSH SI
  PUSH DI
  PUSH BP
  PUSH ES
  INT  10H
  POP  ES
  POP  BP
  POP  DI
  POP  SI
end;

procedure GetXY(var Col, Row: Byte); Assembler;
asm
  push es
  push di
  MOV  AH,03h
  XOR  BH,BH
  INT  10H
  INC  DH
  INC  DL
  les  di, Col
  mov  Byte Ptr es:[di], dl
  les  di, Row
  mov  Byte Ptr es:[di], dh
  pop  di
  pop  es
end;

procedure SetBackGroundIntensity(On: Boolean); Assembler;
asm
  mov bl, On
  or  bl, bl
  jne @To0
  mov bl, 01h
  jmp @Folyt
@To0:
  xor bl, bl
@Folyt:
  mov ax, 1003h
  int 10h
end;

function  IsBackGroundIntensityOn: Boolean;
var B: ^Byte;
begin
  B:=Ptr(Seg0040, $65);
  IsBackGroundIntensityOn:=((B^ and 32) div 32) = 0;
end;

procedure GetScreen(var Kepernyo: TScreen);
var i, j, k: Byte;
begin
  inline($60); {PUSHA}
  for i:=1 to 25 do
    for j:=1 to 80 do
      for k:=1 to 2 do
        Kepernyo[i, j, k]:=Screen^[i, j, k];
  inline($61); {POPA}
end;

procedure PutScreen(Kepernyo: TScreen);
var i, j, k: Byte;
begin
  inline($60); {PUSHA}
  for i:=1 to 25 do
    for j:=1 to 80 do
      for k:=1 to 2 do
        Screen^[i, j, k]:=Kepernyo[i, j, k];
  inline($61); {POPA}
end;

{Char edit}
procedure NewCharOn(Dat: Pointer; Car, Fm: Word); Assembler;
asm
  {$IfNDef DPMI}
  xor  dx, dx
  mov  bx, OFFSET @Code1
  mov  cx, OFFSET @CodePre2
  sub  cx, bx
  cmp  Byte Ptr cs:[bx], 163
  jne  @ContCode
@ContXOR:
  xor  Byte Ptr cs:[bx], 165
  inc  bx
  inc  dx
  cmp  dx, cx
  jb   @ContXOR
  jmp  @Code1

@ContCode:
  push bx
  retn
  dw   0303h {=> 0303h}
  dw   0310h {=> 1003h}
  {$ENDIf}

@Code1:
  push es
  push ds
  {$IfDef DPMI}
  mov  ax, SegA000 {0A000h}
  {$ELSE}
  mov  ax, 0A000h
  {$ENDIf}
  mov  es, ax
  lds  si, Dat
  mov  di, Car
  shl  di, 5
  mov  cx, Fm
  cld

  mov  dx, 03CEh
  mov  ax, 0005h
  out  dx, ax
  mov  ax, 0406h
  out  dx, ax
  mov  dx, 03C4h
  mov  ax, 0402h
  out  dx, ax
  mov  ax, 0704h
  out  dx, ax

  rep  movsb

  mov  ax, 0302h
  out  dx, ax
  mov  ax, 0304h
  out  dx, ax
  mov  dx, 03CEh
  mov  ax, 1005h
  out  dx, ax
  mov  ax, 0E06h
  out  dx, ax

  pop  ds
  pop  es

  jmp  @Code2
@CodePre2:
  {$IfNDef DPMI}
  dw   0303h {=> 0303h}
  dw   0310h {=> 1003h}
  {$ENDIf}
@Code2:
end;

procedure NewCharsOn(CharSet: TChrData; car, fm, count: Word);
var i, k: Byte;
begin
  if Count > 255 then Count:=1;
  for i:=Car to Car + Count do
  begin
    for k:=0 to 15 do
      Temp2[k]:=CharSet[i*16+k];
    NewCharOn(Addr(Temp2), i, fm);
  end;
end;

procedure GetChar(dat: Pointer; Car, Fm: Word); Assembler;
asm
  push ds
  push es
  {$IfDef DPMI}
  mov  ax, SegA000 {0A000h}
  {$ELSE}
  mov  ax, 0A000h
  {$ENDIf}
  mov  ds, ax
  les  di, Dat
  mov  si, Car
  mov  cl, 5
  shl  si, Cl
  mov  cx, Fm
  cld

  mov dx, 3C4h; {  Sequencer port address  }
  mov ax, 0704h; {  Sequential addressing  }
  out dx, ax;
  mov dx, 03CEh
  mov ax, 0005h; { Disable odd-even addressing }
  out dx, ax;
  mov ax, 0406h; { Map starts at A000:0000 (64K mode) }
  out dx, ax
  mov ax, 0204h { Map starts at A000:0000 (64K mode) }
  out dx, ax;

  rep movsb

  mov  dx, 3C4h; { Sequencer port address }
  mov  ax, 0302h
  out  dx, ax
  mov  ax, 0304h
  out  dx, ax
  mov  dx, 03CEh
  mov  ax, 1005h
  out  dx, ax
  mov  ax, 0E06h
  out  dx, ax
  mov  ax, 0004h
  out  dx, ax

  pop  es
  pop  ds
end;

procedure GetChars(var CharSets: TChrData; Car, Fm, Count: Word);
var i, k: Byte;
begin
  if Count > 255 then Count:=255;
  for i:=Car to Car + Count do
  begin
    GetChar(Addr(Temp2), i, fm);
      for k:=0 to 15 do
       CharSets[i*16+k]:=Temp2[k];
  end;
end;

procedure GetSaveableChars;
begin
  GetChars(SavedFont, 0, 16, 255);
end;

procedure PutSavedChars;
begin
  NewCharsOn(SavedFont, 0, 16, 255);
end;

  {$IfNDef DPMI}
    procedure PCX_Font; external {$L PCX_Font};
  {$Else}
    procedure PCX_Font; external {$L PCX_Fond};
  {$ENDIf}

procedure AddFontsToLogicalFontTable(NameOfArray: TChrData;FromASCII,ASCIICount:Byte);
var Ckl, D: Word;
begin
  D:=0;
  for Ckl:=FromASCII*16 to (FromASCII*16)+(ASCIICount*16)-1 do
  begin
    CharSet[Ckl]:=NameOfArray[D];
    D:=D+1;
  end;
end;

procedure SetPCXGraphChars(State: Boolean);
begin
  IsPCXGraphCharsOn:=State;
  if State
  then begin
         Move(@PCX_Font^, Addr(CharSet)^, 4096);
         AddFontsToLogicalFontTable(CharSet, 0, 255);
         NewCharsOn(CharSet, 0, 16, 255);
       end
  else asm
         mov  ax, 1104h
         xor  bl, bl
         int  10h
       end;
end;


{Key}
procedure KeyStrokeToKeyboardBuffer(ASCII, ScanC: Byte); Assembler;
asm
  mov ah,  05h
  mov cl,  ASCII
  mov ch,  ScanC
  int 16h
end;


{Internal}
function  GetVideoSeg: Word;
begin
  if GetPrimaryAdapterType = $01 then GetVideoSeg:=SegB000  {MDA}
                                 else GetVideoSeg:=SegB800; {Not MDA}
end;


BEGIN
  if Test8086 < 2 then begin
                         WriteLn;
                         WriteLn('Error: This program required least 386 CPU !');
                         WriteLn('Exitting . . .');
                         ExitCode:=$FF;
                       end
                  else begin
                         Screen:=Ptr(GetVideoSeg, $0000);

                         {$IFDef DPMI}
                         SegC000:=ConvertPhisicalAddrToDPMIAddr($C0000);
                         SegD000:=ConvertPhisicalAddrToDPMIAddr($D0000);
                         SegE000:=ConvertPhisicalAddrToDPMIAddr($E0000);
                         SegF000:=ConvertPhisicalAddrToDPMIAddr($F0000);
                         {$ENDIf}

                         {if Not (SearchForParameter('/NoDumpCache') or SearchForParameter('-NoDumpCache')) then
                         begin
                           if IsInstalledNUTSR(NU_NCache_S) then FlushBuffesrsNUTSR(NU_NCache_S);
                           if IsInstalledNUTSR(NU_NCache_F) then FlushBuffesrsNUTSR(NU_NCache_F);
                           if IsSmartDrvInstalled then CommitCacheSmartDrv;
                         end;}

                         {OldExitProc:=ExitProc;
                         ExitProc:=@PCXExitProc;}
                       end;
END.