Unit Extense;
{$G+}
Interface

Type PalType = Array[0..255,1..3] of Byte;
     SStr    = String[20];
     MStr    = String[80];
     LStr    = String[255];
     String8 = String[8];
Var
  Pall           : PalType;
  Screen         : Array[0..$b800] of byte absolute $b800:0000;

{-- Video Functions --}
Function  VidSeg     : Word;
Function  VGA_Card   : Boolean;
Function  Color_Card : Boolean;
Function  IsVesa     : Boolean;
Function  VideoMode  : Byte;
Procedure ClearScreen;
Procedure Reset_Video;
Procedure Change_28;
Procedure Change_30;
Procedure WaitRetrace;
Procedure VGA_SetBlink(BlinkMode : Boolean);
Procedure VGA_SetFontSize(FontSize:Byte);
Procedure VGA_SetPallette(ColorNo : Byte; R,G,B : Byte);
Procedure VGA_GrabPallette;
Procedure VGA_GetPallette(Col : Byte; Var R,G,B : Byte);
Procedure VGA_FadeUp;
Procedure VGA_FadeDown;                                        { Fade Colors to Black    }
Procedure VGA_GreyScale;                                       { Set Colors to Greyscale }
Procedure VGA_RestorePallette;                                 { Restore Colors to Valusses stored with GRABPALLETTE }
Procedure VGA_Blinking(State : Boolean);                       { Toggle High Backgrounds/Blinking }
Procedure VGA_Set8x16Font;                                     { Change to 8x16 Font     }
Procedure Color(F,B : BYTE);                                   { Change Current Color    }
Procedure ClearLine(Line : Byte);                              { Clear a Line in Text Mode }
Procedure GoXy(x,y : Word);                                    { Goto Xth Column, and Yth Row }
Procedure Setcursorshape(shape : word);                        { Set the Cursor Height }
Procedure qwrite(x,y:byte;s:string;f,b:byte;CharsperRow:Word); { Write Text Directly to Screen }
Procedure Uncrunch(var Addr1,Addr2; BlkLen:Integer);           { Display a THEDRAW Crunch File }
Procedure Putpixel(X,Y : Word;Color : Byte;Where : Word);
Procedure SetScreenStart(ScanLine:word);                       { Set Display Window's First Scanline }
Procedure Yescursor;                                           { Enable the Blinking Cursor }
Procedure Nocursor;                                            { Disable the Blinking Cursor }

{-- Keyboard Functions --}
Procedure SetTypeRate(Kdelay, Krate:Byte);                     { Set Typematic Rate of Keyboard }
Function  ShiftState : Byte;                                   { Returns the Current Shiftstate }
Function  ScrollLock : Boolean;                                { True if ScrollLock is Active   }
Function  CapsLock   : Boolean;                                { True if CapsLock is Active     }
Function  InsKey     : Boolean;                                { True if Insert is Active       }
Function  AltKey     : Boolean;                                { True if ALT is Depressed       }
Procedure Clear_Keyboard_Buffer;                               { Clears Keyboard Que            }
Function  Yesno(unlit,lit : Byte) : Boolean;                   { Get Yes/No Input with Lightbars}
Procedure InputNums(var Lne:String;Chars:Byte;AllowZero:Boolean);{ Gets Input and Stores as a String, Allows only Digits}
Procedure InputLn(var Lne : String;Chars:Byte;Caps:Boolean;Allcaps:Boolean;Start : String);
Procedure InputRelaxed(var Lne:String;Chars:Byte;Caps:Boolean;Allcaps:Boolean);{ Gets Input, allowing ALL Characters}
Procedure GetKeys(Var C1 : Char;Var C2 : Char);                { Gets Double Keystroke Codes }
Function  Get_Extended_KeyCode : Word;                         { Gets Extended Keystroke Codes }

{-- String Functions --}
function valu (q:mstr):integer;
Function  Comma(I : LongInt): String;                          { Formats a Number, inserting Comma's where needed}
Function  Uppercase(Str : String) : String;                    { Changes a String to Uppercase }
Function  Strr(I : LongInt) : String;                          { Returns the String value of a Number }
Function  Center(Str : String) : Byte;                         { Returns the X Position to center the string on screen}
function str2real(s : string) : real;
Function  Padcenter(Str : String;Amount : Byte) : String;      { Pads the String so it fits centered in a box }
Function  Padstring(Outp : String;Number : Byte): String;      { Pads the String to the Right }
Function  LeadingZero(w : Word) : String;                      { Adds a leading zero to numbers below 10 }
Function  ASCIZToString (ASCIZ: array of Char): String;        { Changes an ASCIZ String to a Pascal Style String }
Function  StrJust(S : String; Size : Byte) : String;           { Justify a String }
function  Real2String (r:real):mstr;                           { Returns the String value of a Real Number }
function  Str2Byte(q:mstr):integer;                            { Returns the Integer value of a String }
Function  Hex(Value:Byte):string;                              { Returns the Hex value of a Decimal Byte }
Function  HexWord(a : Word) : String;
FUNCTION  HexToLong(S : STRING) : LONGINT;
Function  UpString(S:String) : String;
Function  DWNCase(CH:Char):Char;
Procedure LongToHex(AnyLong : LongInt; Var HexString : String8);

{-- Memory Handling --}
Procedure FillWord(var x; count:integer; w:word);              { Fills an area of memory by words }
Procedure FastMove(VAR source;VAR dest;numToMove : WORD);      { Moves bytes from one memory location to another }
Procedure MovW(var source,dest; num: word);                    { Moves words from one memory location to another }
Procedure Cold_Boot;                                           { Re-boots the computer Cold/Slow    }
Procedure Warm_Boot;                                           { Re-boots the computer Warmly/Quick }

{-- Character Handling --}
function IsLower(c:char):boolean;                              { True if Character is Lowercase }
function IsUpper(c:char):boolean;                              { True if Character is Uppercase }
Function IsAlpha(c:char):boolean;                              { True if Character is a Letter  }
Function IsDigit(k:char):boolean;                              { True if Character is a Number  }
Function IsAlNum(c:char):boolean;                              { True if Character is a Number OR Letter }

{-- Bitwise Opperations --}
Function  GetBitA(var a;Bit:Word):Boolean;                     { True if Bit is Active }
Procedure InvertBitA(var a;Bit:Word);                          { Invert a specific Bit }

{-- Misc. Schtuff --}
Procedure Draw_Dialog(X,Y,Height : Byte);                      { Draw an Ansi Dialog Box }
Procedure Clear_Column(Column : Byte);                         { Clear a Column on the Display }
Procedure PipeWrite(S : String;Colors : Boolean);
Procedure FadeWrite(Strng : String);                           { Fades a String onto the Screen }
Procedure Toggle(Var Bln : Boolean);                           { Toggle a Boolean Variable }
Procedure SDelay(S : Word);                                    { Delay,but aborts on keypress }
Function  Now : longint;                                       { Returns the Packed Format of the Current Time/Date }
Function  timestr (time:longint):string;                       { Unpacks a Packed Format Time into a String }
Function  datestr (time:longint):string;                       { Unpacks a Packed Format Date into a String }

{-- Hardware Schtuff --}
Procedure Beep(Freq,Dely : Word);                              { Makes a Sound }
Function  PrinterReady(PN: word): boolean;                     { True if Printer is Ready }
Function  SoundBlaster : Boolean;                              { True if a Sound Blaster Exists }
Procedure SetTurbo(Turbo : Boolean);                           { Enable/Disable Turbo }
Procedure PrintScreen(On : Boolean);                           { Enable/Disable PrintScreen }
Function  Windows : boolean;                                   { True if in Microsoft Windows }

{-- Mouse Schtuff --}
Procedure Mousesensetivity(x,y:word);                          { Change Mouse Sensitivity          }
Procedure mouseinit;                                           { Initialize Mouse for Use          }
Procedure mouseon;                                             { Enable Hardware Mouse Cursor      }
Procedure mouseoff;                                            { Disable Hardware Mouse Cursor     }
Function  mousex: word;                                        { Returns Mouse's X Position        }
Function  mousey: word;                                        { Returns Mouse's Y Position        }
Function  mouseleft: boolean;                                  { True if Left Button is Pressed    }
Function  mousemiddle: boolean;                                { True if Middle Button is Pressed  }
Function  mouseright: boolean;                                 { True if Right Button is Pressed   }
Procedure setmousexy(newx, newy: word);                        { Sets Mouse Position               }
Procedure limitmouse(lox,loy,hix,hiy:word);                    { Limit where the mouse can go      }

{-- Screen Clearing Methods --}
Procedure Woop_dat_screen;
Procedure PulltheBars;
Procedure RollUp;
Procedure Column_Clear;
Procedure Row_Clear;
Procedure Close_Horizontal;
Procedure Close_Vertical;
Procedure SlideUp;
Procedure SlideDown;
Procedure SlideLeft;
Procedure SlideRight;
Procedure Squish_Screen;

{-- File Handling --}
Function  FileExist(FileName : String) : Boolean;              { True if Fhle Exists          }
Procedure DeleteFile(FileName : string);                       { Deletes a File               }
Function  Is_Directory(StDir : String): Boolean;               { True if Input is a Directory }
Function  DirExist(StDir : String): Boolean;                   { True if Directory Exists     }
Function  Is_Floppy(D: Byte) : Boolean;                        { True if Drive is a Floppy    }
Function  Is_CDRom(Drv : Char) : Boolean;                      { True if Drive is a CD-ROM    }
Function Get_Cur_Dir : String;
Function Get_Prg_Dir : string;

Var Mouseexist, MouseCursorOn: Boolean;

Implementation

Uses Dos,Crt,Strings;

Var Kb : Byte Absolute $0040:$0017;
    regs: registers;
    xshift, yshift: byte;

function valu (q:mstr):integer;
var i,s,pu:integer;
    r:real;
begin
  While Q[Byte(Q[0])]=#32 Do Q[Byte(Q[0])]:=Pred(Q[Byte(Q[0])]);
  valu:=0;
  if byte(q[0])=0 then exit;
  if not (q[1] in ['0'..'9','-']) then exit;
  if byte(q[0])>5 then exit;
  val (q,r,s);
  if s<>0 then exit;
  if (r<=32767.0) and (r>=-32767.0)
    then valu:=round(r)
end;

function str2real(s : string) : real;
Var Temp : Real;
    Error : Integer;
Begin
{procedure Val(S; var V; var Code: Integer);}
 Val(S,Temp,Error);
 str2real := Temp;
End;

Function Get_Cur_Dir : String;
Var Temp : String;
Begin
 GetDir(0,Temp);
 Get_Cur_Dir := Temp;
End;

Function Get_Prg_Dir : string;
var Tmp : string;
Begin
 Tmp := ParamStr(0);
 while (Tmp[Length(Tmp)] <> '\') and (Length(Tmp) <> 0) do Delete(Tmp,Length(Tmp),1);
 if Tmp = '' then Tmp := Get_Cur_Dir;
 If Tmp[Length(Tmp)] <> '\' then Tmp := Tmp + '\';
 Get_Prg_Dir := Tmp;
End;

Procedure LongToHex(AnyLong : LongInt; Var HexString : String8);
Var ch    : Char;
    Index : Byte;
begin
 HexString := '00000000';                  { default to zero   }
 Index := Length(HexString);               { String length     }
 While AnyLong <> 0 do
 begin                                     { loop 'til done    }
  ch := Chr(48 + Byte(AnyLong) and $0F);   { 0..9 -> '0'..'9'  }
  if ch > '9' then Inc(ch,7);
  HexString[Index] := ch;                  { insert Char       }
  Dec(Index);                              { adjust chr Index  }
  AnyLong := AnyLong SHR 4;                { For next nibble   }
 end;
end;



FUNCTION HexWord(a : Word) : String;
CONST  Digit          : ARRAY[$0..$F] OF Char = '0123456789ABCDEF';
VAR
  I              : Byte;
  HexStr         : String;
BEGIN
 HexStr := '';
 FOR I := 1 TO 4 DO
 BEGIN
  Insert(Digit[a AND $000F], HexStr, 1);
   a := a SHR 4
 END;
 HexWord := HexStr;
END;                            {hex}

Procedure stoupper(Var ST: String);
begin
   Inline(
     $C4/$7E/$06/           {   les di,[bp]6         ;es:di -> st[0]}
     $26/                   {   es:}
     $8A/$0D/               {   mov cl,[di]          ;cl = length}
     $FE/$C1/               {   inc cl}

                            {next:}
     $47/                   {   inc di}
     $FE/$C9/               {   dec cl}
     $74/$12/               {   jz ends}

     $26/                   {   es:}
     $8A/$05/               {   mov al,[di]}
     $3C/$61/               {   cmp al,'a'}
     $72/$F4/               {   jb next}
     $3C/$7A/               {   cmp al,'z'}
     $77/$F0/               {   ja next}

     $2C/$20/               {   sub al,' '}
     $26/                   {   es:}
     $88/$05/               {   mov [di],al}
     $EB/$E9);              {   jmp next}

                            {ends:}
end;

Function UpString(S:String) : String;
Begin
 StoUpper(S);
 UpString:=S;
End;

Function DWNCase(CH:Char):Char;
begin
 if CH in['A'..'Z'] then CH := Chr(Ord(CH)+32) else CH := CH;
 DWNCase := Ch;
end;


Function Color_Card : Boolean;
Var Display: Byte Absolute $40:$10;
begin
 Color_Card := Not((Display and $30) = $30);
End;

procedure calcshifts;                     {  coordinates.  It's a matter of   }
var tempregs: registers;                  {  shifting left/right; xshift      }
begin                                     {  records how to shift the "X",    }
  tempregs.ah := $0f;                     {  and yshift records for the "Y".  }
  intr($10, tempregs);                    { Procedure CalcShifts figures out  }
  case tempregs.al of                     {  what text mode you're in and how }
    0, 1, 2, 3, 7: begin                  {  much to shift by.  It gets the   }
      xshift := 3;                        {  video mode w/interrupt $10/$0f;  }
      yshift := 3;                        {  modes 0, 1, 2, 3 and 7 are text  }
      end;                                {  modes.  4, 5, $0d and $13 are    }
    4, 5, $0d, $13: begin                 {  320 x 200 graphics modes.  All   }
      xshift := 1;                        {  other graphics modes are okay    }
      yshift := 0;                        {  "as is", although come to think  }
      end;                                {  of it I had a CGA system when I  }
    else begin                            {  wrote this library and thus      }
      xshift := 0;                        {  couldn't text VGA modes ...      }
      yshift := 0;
      end;
    end;
  end;

Procedure mouseinit;
Begin
 regs.ax := $0000;
 intr($33, regs);
 mouseexist := (regs.ax = $FFFF);
 if mouseexist then calcshifts;
 mousecursoron := false;
End;

procedure mouseon;                    { Turns cursor ON. }
begin
 regs.ax := $0001;
 intr($33, regs);
 mousecursoron := true;
end;

procedure mouseoff;
begin
 regs.ax := $0002;
 intr($33, regs);
 mousecursoron := false;
end;

function mousex: word;                { Gets the current mouse column. }
var tempword: word;
begin
 regs.ax := $0003;
 intr($33, regs);
 tempword := regs.cx;
 mousex := tempword shr xshift;
end;

function mousey: word;                { Gets the current mouse row. }
var tempword: word;
begin
 regs.ax := $0003;
 intr($33, regs);
 tempword := regs.dx;
 mouseY := Tempword shr yshift;
end;

Function Mouseleft: Boolean;
Var TempWord : Word;
Begin
 asm MOV AX,3;INT 33h;MOV TempWord,BX End;
 mouseleft := mouseexist and (1 and tempword = 1);
End;

Function MouseRight: Boolean;
Var TempWord : Word;
Begin
 asm MOV AX,3;INT 33h;MOV TempWord,BX End;
 mouseright := mouseexist and (2 and tempword = 2);
End;

Function MouseMiddle: Boolean;
Var TempWord : Word;
Begin
 Asm MOV AX,3;INT 33h;MOV TempWord,BX End;
 mousemiddle := mouseexist and (4 and tempword = 4);
End;

procedure setmousexy(newx, newy: word);   { Position mouse cursor. }
begin
 regs.ax := $0004;
 regs.cx := newx shl xshift;             { Shifts to get it into "mouse" }
 regs.dx := newy shl yshift;             {  coordinates. }
 intr($33, regs);
end;

procedure limitmouse(lox, loy, hix, hiy: word);   { Restrict mouse movements. }
begin
 regs.ah := $0f;
 intr($10, regs);
 regs.ax := $0007;
 regs.cx := lox shl xshift;
 regs.dx := hix shl xshift;
 intr($33, regs);
 regs.ax := $0008;
 regs.cx := loy shl yshift;
 regs.dx := hiy shl yshift;
 intr($33, regs);
End;



function timestr (time:longint):string;
var h1:integer;
    ms:sstr;
    dt:datetime;
const ampmstr:array [false..true] of string[2]=('am','pm');
begin
 unpacktime (time,dt);
 h1:=dt.hour;
 if h1=0 then h1 := 12 else if h1>12 then h1:=h1-12;
 ms := strr(dt.min);
 if dt.min<10 then ms:='0'+ms;
 timestr := strr(h1) + ':' + ms + ' '+ ampmstr[dt.hour>11]
end;

function datestr (time:longint):string;
var dt:datetime;
begin
  unpacktime (time,dt);
  datestr:=leadingzero(dt.month)+'/'+leadingzero(dt.day)+'/'+leadingzero(dt.year-1900)
end;

Function IsAlpha(c:char):boolean;
{returns true if c is an upper or lower case letter}
Begin
Inline($59/$B0/$00/$80/$F9/$41/$72/$11/$80/$F9/$5A/$76/$0A/$80/$F9/$61/
  $72/$07/$80/$F9/$7A/$77/$02/$B0/$01);
End;

Function Windows : boolean; assembler;
Asm
 MOV AX,1600h
 INT 2Fh
End; { Running Under MS-Windows }

Procedure Change_30;
Const Regvalues : Array[1..8] of Word =
($0c11,$0d06,$3e07,$ea10,$8c11,$df12,$e715,$0616);
Var
  X,I,Data : Byte;
  Offset   : Word;
Begin
 MemW[$0040:$004c]:= 8192;
 Mem[$0040:$0084] := 29;
 Offset := MemW[$0040:$0063];
 Asm cli End;
 For I := 1 to 8 do PortW[Offset]:=Regvalues[i];
 Data := Port[$03cc];
 Data := Data And $33;
 Data := Data Or $C4;
 Port[$03c2] := Data;
 Asm
  sti
  mov ah,12h
  mov bl,20h
  int 10h
 End;
End;

function IsLower (c:char):boolean;
{Returns true of c is a lower case letter}
Begin
Inline($59/$B0/$00/$80/$F9/$61/$72/$07/$80/$F9/$7A/$77/$02/$B0/$01);
End;

function IsUpper (c:char):boolean;
  {returns true if c is an upper case letter}
Begin
Inline($59/$B0/$00/$80/$F9/$41/$72/$07/$80/$F9/$5A/$77/$02/$B0/$01);
End;

Function IsAlNum(c:char):boolean;
 {returns true if c is a letter or a digit}
Begin
Inline(                  {Assembly by Inline 01/12/88 23:45}
  $59/                   {          pop  cx}
  $B0/$00/               {          mov  al,0}
  $80/$F9/$30/           {          cmp  cl,'0'}
  $72/$1B/               {          jb   done}
  $80/$F9/$39/           {          cmp  cl, '9'}
  $76/$14/               {          jbe  OK}
  $80/$F9/$41/           {          cmp  cl,'A'}
  $72/$11/               {          jb   done}
  $80/$F9/$5A/           {          cmp  cl,'Z'}
  $76/$0A/               {          jbe  OK}
  $80/$F9/$61/           {          cmp  cl, 'a'}
  $72/$07/               {          jb   done}
  $80/$F9/$7A/           {          cmp  cl,'z'}
  $77/$02/               {          ja   done}
  $B0/$01                {  OK:     mov  al,1}
 );                      {  done:}
End;

Procedure Change_28;Assembler;
Asm
 mov ax,1202h
 mov bl,30h
 int 10h
 mov ax,0003h
 Int 10h
 mov ax,1111h
 mov bl,00h
 int 10h
end;

Function IsDigit(k:char):boolean;
Begin
 IsDigit := Ord(k) in [48..57];
End;

Procedure Color (F,B : BYTE); Assembler;
ASM
  MOV    AL, B
  SHL    AL, 4
  OR     AL, F
  MOV    TextAttr, AL
END;

function packtime (var dt:datetime):longint;
var l:longint;
begin
  dos.packtime (dt,l);
  packtime:=l
end;

function now:longint;
var dt:datetime;
    t:word;
    l:longint;
begin
  gettime (dt.hour,dt.min,dt.sec,t);
  getdate (dt.year,dt.month,dt.day,t);
  l:=packtime (dt);
  now:=l
end;

Function ASCIZToString(ASCIZ: array of Char): String;
Begin
End;

Procedure VGA_GrabPallette;
Var X : Integer;
Begin
  For X := 0 to 255 do VGA_Getpallette(X,pall[X,1],pall[X,2],pall[X,3]);
End;

Function SoundBlaster : Boolean;
Const NrTimes           = 10;
      NrTimes2          = 50;
Var   Found             : Boolean;
      Counter1,Counter2 : Word;
      SBPort      : Word;
Begin
 SBPort  := $210;
 Found   := False;
 Counter1:= NrTimes;
 While (SBPort<=$260) And Not Found Do
  Begin
   Port[SBPort+6] := 1;
   Port[SBPort+6] := 0;
   Counter2 := NrTimes2;
   While (Counter2>0) And (Port[SBPort+$E]<128) Do Dec(Counter2);
   If (Counter2=0) Or (Port[SBPort+$A]<>$AA) Then
    Begin
     Dec(Counter1);
     If (Counter1=0) Then
      Begin
       Counter1:=NrTimes;
       SBPort:=SBPort+$10;
      End
    End Else Found := True;
  End;
 SoundBlaster := Found;
End;

Procedure SDelay(S : Word);
Var X : Word;
    SX,SY : Byte;
Begin
 For X := 1 to S do
  Begin
   Delay(1);
   If Keypressed then Exit;
  End;
End;

Function ShiftState: Byte;
Var Regs: Registers;
Begin
  Regs.Ah:=2;
  Intr($16, Regs);
  ShiftState:=Regs.Al;
End;

Procedure VGA_GetPallette(Col : Byte; Var R,G,B : Byte);
Var rr,gg,bb : Byte;
Begin
   asm
      mov    dx,3c7h
      mov    al,col
      out    dx,al
      add    dx,2
      in     al,dx
      mov    [rr],al
      in     al,dx
      mov    [gg],al
      in     al,dx
      mov    [bb],al
   end;
   r := rr;g := gg;b := bb;
end;

function VidSeg: Word;
var
  VidM: ^Byte;
begin
  {$iFDEF VER70}
  VidM := Ptr(Seg0040,$0049);
  if VidM^ = 7 then VidSeg := SegB000 else VidSeg := $b800;
  {$ELSE}
  VidM := Ptr($0040,$0049);
  if VidM^ = 7 then VidSeg := SegB000 else VidSeg := $b800;
  {$ENDiF}
end;

Procedure Clear_Keyboard_Buffer;
Begin
 MemW[$0000:$041C] := MemW[$0000:$041A];
End;

Procedure VGA_SetPallette(ColorNo : Byte; R,G,B : Byte);Assembler;
asm
 mov dx,$3c8
 xor ax,ax
 mov al,ColorNo;out dx,al
 mov dx,$3c9
 mov al,r;out dx,al
 mov al,g;out dx,al
 mov al,b;out dx,al
end;

Procedure VGA_GreyScale;
Var X     : Byte;
    RedReal,GreenReal,BlueReal : Real;
    R,G,B : Byte;
    Grey  : Integer;
Begin
For X := 0 to 255 do
Begin
 VGA_GetPallette(X,R,G,B);
 RedReal   := R;
 GreenReal := G;
 BlueReal  := B;
 Grey := Round((RedReal * 0.30)+(GreenReal * 0.59)+(BlueReal * 0.11));
 VGA_SetPallette(X,Grey,Grey,Grey);
End;
End;

Procedure VGA_RestorePallette;
Var loop1 : Integer;
Begin
  For loop1 := 0 to 255 do VGA_setpallette(loop1,Pall[loop1,1],Pall[loop1,2],Pall[loop1,3]);
End;


Procedure VGA_Fadeup;
Var loop1,loop2 : Byte;
    Tmp         : Array [1..3] of Byte;
Begin
  For loop1:=1 to 64 do BEGIN
  WaitRetrace;
    For loop2:=0 to 255 do BEGIN
      VGA_Getpallette(loop2,Tmp[1],Tmp[2],Tmp[3]);
      If Tmp[1]<Pall[loop2,1] then inc(Tmp[1]);
      If Tmp[2]<Pall[loop2,2] then inc(Tmp[2]);
      If Tmp[3]<Pall[loop2,3] then inc(Tmp[3]);
      VGA_SetPallette (loop2,Tmp[1],Tmp[2],Tmp[3]);
    End;
  End;
End;

Procedure VGA_FadeDown;
VAR loop1,loop2:integer;
    Tmp : Array [1..3] of byte;
BEGIN
  For loop1:=1 to 64 do BEGIN
    For loop2:=0 to 255 do BEGIN
      Waitretrace;
      VGA_Getpallette (loop2,Tmp[1],Tmp[2],Tmp[3]);
      If Tmp[1]>0 then dec(Tmp[1]);
      If Tmp[2]>0 then dec(Tmp[2]);
      If Tmp[3]>0 then dec(Tmp[3]);
      VGA_SetPallette (loop2,Tmp[1],Tmp[2],Tmp[3]);
    END;
  END;
END;

Function Comma(I : LongInt): String;
Var S : String[80];
    X : Integer;
Begin
 Str(i:0,s);
 x := Length(s)-2;
 While x > 1 do Begin
                 Insert(',',s,x);
                 Dec(x,3);
                End;
 Comma := s;
End;

PROCEDURE VGA_SetFontSize (FontSize:Byte); ASSEMBLER;
ASM
 MOV    DX,$03D4          { CRTC address register             }
 MOV    AL,9              { Index for Max Scanline Register   }
 OUT    DX,AL             { set MSL as active register        }
 INC    DX                { Set DX to CRTC Data register      }
 IN     AL,DX             { read current MSL                  }
 AND    AL,011100000b     { set MSL to 0, preserve others bits}
 MOV    AH,[FontSize]     { get required size                 }
 DEC    AH                { minus one.                        }
 OR     AL,AH             { set size in MSL field             }
 OUT    DX,AL             { Writeback modified value          }
End;

Procedure NoCursor;Assembler;
 asm mov ah,1; mov cx,2000h;Int 10h end; {No Cursor}

Procedure YesCursor;Assembler;
 asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}

function PrinterReady(PN: word): boolean; assembler;
asm
    mov     dx, PN              {printer number goes in DX}
    mov     ah, 02h
    int     17h                 {int. 17h service 02h}
    xor     al, al              {assume false}
    and     ah, 10101000b       {clear all other bits}
    cmp     ah, 10000000b       {ready & not out of paper or error?}
    jne     @Done               {no -- leave result false}
    inc     ax                  {yes -- change to true}
@Done:
end;

Function Is_Floppy(D: Byte) : Boolean;
Var Regs: Registers;
Begin
 regs.ax:= $4408;
 regs.bl:= d;
 Msdos(Regs);
 Is_floppy := ((regs.flags and fcarry) = 0) and (regs.ax = 0);
End;

Function Is_CDRom(Drv : Char) : Boolean;
Var
 Regs : Registers;
 Cdr  : string;
 Cnt  : byte;
Begin
 Is_CdRom := False;
 Cdr := '';
 regs.ax := $1500;
 regs.bx := 0;
 regs.cx := 0;
 Intr($2F,Regs);
 If regs.bx > 0 then
   For cnt := 0 to (regs.bx-1) do cdr := cdr+char(regs.cl+Byte('A')+cnt);
 Is_CDRom := Pos(upcase(Drv),cdr)>0
End;

Function Hex(Value:byte):string;
Const HexTable : Array[0..15] of Char=
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
Var HexStr : String;
Begin
  HexStr[2]:=HexTable[Value and $0F];        { Convert low nibble }
  HexStr[1]:=HexTable[Value and $F0 div 16]; { Convert high nibble }
  HexStr[0]:=#2; { Set Stringlength }
  Hex := HexStr;
End;

Function VideoMode : Byte;
Var
  Mode : Byte;
begin
  Asm
    MOV AH, 0Fh              { Set Function to 0Fh - Get current video mode }
    INT 10h                  { Call interrupt 10h - Video Services }
    MOV Mode, AL             { Move INT 10h result to Mode Variable }
  end;
  VideoMode := Mode;
end;

FUNCTION HexToLong(S : STRING) : LONGINT;
    FUNCTION ANumBin (B : STRING) : LONGINT; Assembler;
    ASM
      LES DI, B
      XOR CH, CH
      MOV CL, ES : [DI]
      ADD DI, CX
      MOV AX, 0
      MOV DX, 0
      MOV BX, 1
      MOV SI, 0
      @LOOP :
        CMP BYTE PTR ES : [DI], '1'
        JNE @NotOne
          ADD AX, BX   {add power to accum}
          ADC DX, SI
        @NotOne :
        SHL SI, 1      {double power}
        SHL BX, 1
        ADC SI, 0
        DEC DI
      LOOP @LOOP
    END;

CONST
  HexDigits : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
  Legal     : SET OF Char = ['$','0'..'9','A'..'F'];
  BinNibbles : ARRAY [0..15] OF ARRAY [0..3] OF CHAR = (
    '0000', '0001', '0010', '0011',
    '0100', '0101', '0110', '0111',
    '1000', '1001', '1010', '1011',
    '1100', '1101', '1110', '1111');

VAR I : BYTE;
    O : STRING;

BEGIN
O := '';
HexToLong := 0;       { Returns zero if illegal characters found }
IF S = '' THEN EXIT;
FOR I := 1 TO LENGTH(S) DO
    BEGIN
    IF NOT (S[i] in LEGAL) THEN EXIT;
    O := O + binNibbles[PRED(POS(S[i],Hexdigits))];
    END;
HexToLong := ANumBin(O)
END;


Procedure PrintScreen(On : Boolean);
Begin
Mem[$0050:0000] := Byte(On);
{ If On then Mem[$0050:0000] := 1 else Mem[$0050:0000] := 0}
End;

function Str2Byte(q:mstr):integer;
var i,s,pu: integer;
    r     : real;
begin
  While Q[Byte(Q[0])]=#32 Do Q[Byte(Q[0])]:=Pred(Q[Byte(Q[0])]);
  Str2Byte:=0;
  if byte(q[0])=0 then exit;
  if not (q[1] in ['0'..'9','-']) then exit;
  if byte(q[0]) > 5 then exit;
  val (q,r,s);
  if s<>0 then exit;
  if (r<=32767.0) and (r>=-32767.0) then Str2Byte:=round(r)
end;


function Real2String (r:real):mstr;
var q:mstr;
begin
 str (r:0:5,q);
 Real2String := q
end;

Function StrJust(S : String; Size : Byte) : String;
Begin
  While Length(S) < Size Do Insert(#32, S, 1);
  StrJust := S;
End;

Procedure Toggle(Var Bln : Boolean);
Begin
 Bln := Not(Bln);
End;

Procedure DeleteFile(FileName : string); Assembler;
Asm
  push ds
  lds si,FileName
  inc byte ptr [si]
  mov bl,byte ptr [si]
  xor bh,bh
  mov dx,si
  inc dx
  mov byte ptr [si+bx],0
  mov ah,41h
  int 21h
  pop ds
End;


Procedure Warm_Boot;
Begin
 Inline($BB/$00/$01/$B8/$40/$00/$8E/$D8/$89/$1E/$72/$00/$EA/$00/$00/$FF/$FF);
End;

Procedure Cold_Boot;
Begin
 Inline($BB/$38/$12/$B8/$40/$00/$8E/$D8/$89/$1E/$72/$00/$EA/$00/$00/$FF/$FF);
End;

Procedure Squish_Screen;
Label Rulp;
Begin
 asm           { Clear the Next 4 Screens in video memory }
  cld
  mov     ax,$b800
  mov     es,ax
  mov     di,4000
  mov     cx,8000
  mov     ax,0720h
  rep     stosw
  mov     cx,0fh
 End;
rulp:
 asm
  mov     dx,3d4h
  mov     ah,cl
  mov     al,9
  out     dx,ax
 end;
waitretrace;
 asm
  loop    rulp
  xor     di,di
  mov     cx,2000
  mov     ax,0720h
  rep     stosw
  mov     dx,3d4h
  mov     ah,0fh
  mov     al,9
  out     dx,ax
 end;
 asm
  mov ax,3; int 10h;
 end;
End;

Procedure Draw_Dialog(X,Y,Height : Byte);
Var P : Byte;
Begin
 Qwrite(X,Y,'     ÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜ',8,0,80);
 GotoXy(X,Y+1);PipeWrite('|08 Üßßß |07ÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜ|08 ßßßÜ ',True);
 GotoXy(X,Y+2);PipeWrite('|08Þ |15Ü|23                                          |16|07Ü|08 Ý ',True);
 For P := 1 to Height do
  Begin
   GotoXy(X,Y+3+P-1);
   PipeWrite('|08ÞÞ|15|23±|23                                          °|16|07Ý|08Ý ',True);
  End;
 GotoXy(X,Y+Height+3);PipeWrite('|08Þ |08ß|08|23Ü|23|15                                         |16|07ß|08 Ý  ',True);
 GotoXy(X,Y+Height+4);
 Pipewrite('|08 ßÜÜÜ |07ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß|08 ÜÜÜß  ',True);
 Qwrite(X,Y+height+5,'     ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß      ',8,0,80);
End;


Function DirExist(StDir : String): Boolean;
Var
  WoFattr : Word;
  FiTemp  : File;
Begin
 Assign(fiTemp, (stDir + '.'));
 Getfattr(fiTemp, woFattr);
 if (doserror <> 0) then DirExist := false
                    else DirExist := ((woFattr and directory) <> 0)
End;

Function Is_Directory(StDir : String): Boolean;
Var TempFile : File;
   Attribute : Word;
Begin
 Assign(TempFile,stDir);
 GetFattr(TEmpFile,Attribute);
 if (Attribute and Directory) = 0 then Is_Directory := False else Is_Directory := True;
End;

Procedure InputRelaxed(var Lne : String;Chars:Byte;Caps:Boolean;Allcaps:Boolean);
Var
 StartedX,X,Y,Counter,OldAttr : Byte;
 CH   : Char;
 P    : String;
 Done : boolean;
Begin
 OldAttr  := Textattr;
 StartedX := WhereX;
 P        := '';
 Counter  := 0;
 asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}
 Done := False;
 For X := 1 to Chars do Write(' ');GotoXy(StartedX,WhereY);
Repeat
 X := WhereX;
 Y := WhereY;
 MemW[$0000:$041C] := MemW[$0000:$041A];
 CH := Readkey;If CH = #0 then CH := Readkey;
 Case CH of
  #8 : If Counter > 0 then
        Begin
         GotoXy(X-1,Y);Write(' ');
         GotoXy(X-1,Y);Delete(P,Length(P),1);
         Dec(Counter);
        End;
 #13 : Done := True;
 #27 : Begin
        P := 'Aborted';
        Done := True;
       End;
 #32..#255 : If Counter < Chars then
              Begin
               Inc(Counter);
               If Caps then If (P[Counter-1]=#0) or (P[Counter-1]=#32) or (P[Counter-1]=',') then
                CH := Upcase(CH);
               If Allcaps then CH := Upcase(CH);
               P := P + (CH);
               Write(CH);
              End;
     End;
 Until Done = True;
 Lne := P;
 GotoXy(StartedX,WhereY);
 Textattr := 7;For X := 1 to Chars do Write(' ');
 If Lne <> 'Aborted' then Begin
                            GotoXy(StartedX,WhereY);
                            Write(Lne);
                          End;
 Textattr := OldAttr;
End;


Function Get_Extended_KeyCode : Word;
Var Regs : Registers;
Begin
  regs.ah := $10;
  intr($16, regs);
  Get_Extended_KeyCode := (regs.ah shl 4) + regs.al;
End;

Procedure FadeWrite(Strng : String);
Var
 StartX,StartY,X : Byte;
Begin
 StartX := WhereX;
 StartY := WhereY;
 Strng := Strng + '    ';
 For X := 1 to Length(Strng)-4 do
  Begin
   GotoXy(X,WhereY);
   textattr := 8;
   GotoXy(StartX,StartY);
   Write(Copy(Strng,1,X-1));
   Textattr := 8;Write(Strng[X]);
   Textattr := 3;Write(Strng[X+1]);
   Textattr := 11;Write(Strng[X+2]);
   Delay(50);
  End;
End;


procedure FillWord(var x; count:integer; w:word);
Begin
 Inline($c4/$be/x/$8b/$86/w/$8b/$8e/count/$fc/$f2/$ab);
End;

Procedure SetScreenStart(ScanLine:word);
Var StartAddress: Word;
Begin
 StartAddress := (ScanLine div 16)*80;
 portw[$3D4] := hi(StartAddress) shl 8 + $0C;    { Set start address     }
 portw[$3D4] := lo(StartAddress) shl 8 + $0D;
 repeat until port[$3DA] and 8<>0;               { wait for retrace      }
 portw[$3D4] := (ScanLine mod 16) shl 8 + 8;     { Set start scanline    }
 repeat until port[$3DA] and 8=0;                { wait out retrace      }
End;

Function Padcenter(Str : String;Amount : Byte) : String;
Var X : Byte;
 Temp : String;
Begin
 Temp := Str;
 For X := 1 to (Amount div 2) do Temp := ' ' + Temp;
 For X := 1 to (Amount div 2) do Temp := Temp + ' ';
 Padcenter := Temp;
End;

Function Strr(I : LongInt) : String;
Var Strng : String;
Begin
 Str(I,Strng);
 Strr  := Strng;
End;

procedure GoXY(x,y : word);
begin
  asm
    mov    ax,y
    mov    dh,al
    dec    dh
    mov    ax,x
    mov    dl,al
    dec    dl
    mov    ah,2
    xor    bh,bh
    int    10h
  end
end;

Procedure RollUp;
Var X,Y : Integer;
Begin
 For X := 1 to 40 do
Begin
  WaitRetrace;
 For Y := 0 to 25 do
 Begin
  FastMove(Mem[$b800:((Y*160)+ 82)],Mem[$b800:((Y*160)+80)],80);
  FastMove(Mem[$b800:((Y*160))],Mem[$b800:((Y*160)+2)],80);
  Mem[$b800:(Y*160)+1] := 0;
  Mem[$b800:(Y*160)+158] := 0;
 End;
End;
End;

Procedure Woop_dat_screen;
Var X,Y: Byte;
Begin
 For X := 1 to 80 do
 Begin
 WaitRetrace;
 For Y := 0 to 12 do
  Begin
   Mem[$b800:0000+(Y*160)+158] := 0;
   Mem[$b800:0000+(Y*160)+159] := 0;
   Fastmove(Mem[$b800:0000+(Y*160)+2],Mem[$b800:0000+(Y*160)],160-2);
  End;
 For Y := 13 to 25 do
  Begin
   Mem[$b800:0000+(Y*160)+0] := 0;
   Mem[$b800:0000+(Y*160)+1] := 0;
   Fastmove(Mem[$b800:0000+(Y*160)],Mem[$b800:0000+(Y*160)+2],160-2);
  End;
 End;
End;


Procedure Putpixel(X,Y : Word;Color : Byte;Where : Word);Assembler;
Asm
 MOV ax,[Where]
 MOV es,ax
 MOV ah,byte ptr y
 MOV bx,x
 ADD bx,ax
 SHR ax,2
 ADD bx,ax
 MOV al,color
 MOV es:[bx],al
End;

Procedure Reset_Video;Assembler;
Asm
 mov ax,3
 int 10h
End;

Function FileExist(FileName : String) : Boolean; ASSEMBLER;
Asm
  PUSH DS          {Save DS                         }
  LDS  SI,Filename {DS:SI => Filename               }
  XOR  BX,BX       {Clear BX                        }
  MOV  BL,[SI]     {BX = Length(Filename)           }
  INC  SI          {DS:SI => Filename[1]            }
  MOV  DX,SI       {DS:DX => Filename[1]            }
  MOV  [SI+BX],BH  {Append Ascii 0 to Filename      }
  MOV  AX,4300h    {Get Attribute Function Code     }
  INT  21h         {Get File Attributes             }
  MOV  AL,BH       {Default Result = FALSE          }
  ADC  CL,CL       {Attribute * 2 + Carry Flag      }
  AND  CL,31h      {Directory or VolumeID or Failed }
  JNZ  @@Done      {Yes - Exit                      }
  INC  AL          {No - Change Result to TRUE      }
@@Done:
  POP  DS          {Restore DS                      }
End; {FileExists}

Function LeadingZero(W : Word) : String;
Var S : String;
Begin
 Str(w:0,S);
 If Length(s) = 1 then S := '0'+S;
 LeadingZero := S;
End;

Function Uppercase(Str : String) : String;
Var X : Byte;
Begin
 For X := 1 to Length(Str) do Str[X] := Upcase(Str[X]);
 Uppercase := Str;
End;

Procedure SetTurbo(Turbo : Boolean);
Var
  Regs   : Registers;
  OldMem : Byte;
Begin
 If Turbo then Regs.AL := 78 else Regs.AL := 74;
 Regs.AH := $4F;
 Intr($15, Regs);
End;

Procedure ClearLine(Line : Byte);
Begin GotoXy(1,Line);ClrEol; End;

Procedure Mousesensetivity(x,y:word); Assembler;
Asm mov ax,1ah; mov bx,x; mov cx,y; xor dx,dx; int 33h end;

Procedure Setcursorshape(Shape : word);Assembler;
asm mov ah,1;mov cx,shape;int 10h; end;

Procedure VGA_Set8x16Font;ASsembler;
ASM
 MOV    DX,003CCh         { Misc output register READ port    }
 IN     AL,DX             { Read value.                       }
 AND    AL,0F3h           { Bits 2 & 3 off (Clock select 0).  }
 MOV    DX,003C2h         { Misc Output Write port            }
 OUT    DX,AL             { Writeback modified value          }

 CLI                      { NO interrupts for a while         }
 MOV    DX,03C4h          { Sequencer register                }
 MOV    AX,100h           { \ Generate and hold Synchronous   }
 OUT    DX,AX             { / reset                           }

 MOV    AL,001h           { Clocking mode register            }
 OUT    DX,AL             { Activate Clocking mode register   }
 INC    DX                { Data register                     }
 IN     AL,DX             { Read value                        }
 OR     AL,1              { Set Bit 0 (8/9)                   }
 OUT    DX,AL             { Writeback.                        }
 DEC    DX                { Back to Address register          }

 MOV    AX,300h           { \ Release Reset state. (normal)   }
 OUT    DX,AX             { /                                 }

 MOV    DX,03DAh         { CRTC Status register              }
 IN     AL,DX             { Read CRTC Status. (This'll reset  }
                          { Attribute controller flip-flop)   }
 MOV    DX,03C0h         { Attribute controller              }
 MOV    AL,13h            { Horizontal Pixel Pan              }
 OUT    DX,AL             { Activate HPP                      }
 MOV    AL,0              { \ Set HPP to 0                    }
 OUT    DX,AL             { /                                 }
 MOV    AL,20h
 OUT    DX,AL             { Set PAS field (Video has access   }
                          { to palette)                       }

 STI                      { Interrupts allowed again          }
END;

Function CapsLock : Boolean;
Begin
 if (Kb and $40) = $40 then Capslock := True else Capslock := False;
End;

Function ScrollLock : Boolean;
Begin
 If (Kb and $10) = $10 then ScrollLock := True Else ScrollLock := False;
End;

Function Inskey : Boolean;
Begin
 InsKey :=(ShiftState and 128)<>0;
End;

Function AltKey: Boolean;
Begin
 AltKey := (ShiftState and 8)<>0;
End;

Procedure SetTypeRate(Kdelay, Krate:Byte);Assembler;
asm
 Mov AX,$0305;
 Mov BH, Kdelay;
 Mov BL, Krate;
 Int $16;
End;

Procedure VGA_Blinking(State : Boolean);Assembler;
Asm
 MOV AX,1003h
 MOV BH,0
 MOV BL,State
 INT 10h
End;

Procedure GetKeys(Var C1 : Char;Var C2 : Char);
Begin
 C1 := #0;C2 := #0;
 C1 := Readkey;If C1 = #0 then C2 := Readkey;
End;

Function Padstring(Outp : String;Number : Byte): String;
Var X : Byte;
Begin
 For X := 1 to (Number - Length(Outp)) do Outp := Outp + ' ';
 Padstring := Outp;
End;

FUNCTION  VGA_Card : BOOLEAN; ASSEMBLER;
ASM
 MOV    AX,01A00h         { Â> Display Combination Code         }
 INT    10h               { Ù                                   }
 CMP    AL,01Ah           { Is AL=01Ah then it's a VGA          }
 MOV    AL,TRUE           { Assume it'll be true                }
 JE     @Return           { We were right, quit now             }
 MOV    AL,FALSE          { We were wrong, return false         }
@Return:
END;

PROCEDURE VGA_SetBlink      (BlinkMode : BOOLEAN); ASSEMBLER;
ASM
              MOV    DX,$03DA          { CRTC Status register             }
              IN     AL,DX             { Read CRTC Status. (This'll reset }
                                       { Attribute controller flip-flop)  }
            { Set blink bit }
              MOV    DX,$03C0          { Attribute controller (Write port)}
              MOV    AL,10h+20h        { Register 10h (Mode control)      }
                                       { leave PAS field enabled.         }
              OUT    DX,AL             { Activate register 10h            }
              MOV    DX,$03C1          { DX=003C1h (Attribute READ port)  }
              IN     AL,DX             { Read Mode control register       }
              MOV    DX,$03C0          { DX=003C0h (Attribute Write port) }
              CMP    [BlinkMode],TRUE  { BlinkMode = TRUE ?               }
              JE     @SetBlinkBit      {  Yes jump to SetBlinkBit         }
@BlinkOff:    AND    AL,NOT 008h       { Clear the Blink bit              }
              JMP    @SetBlinkBit      { And go tell the VGA card         }
@BlinkOn:     OR     AL,008h           { Clear the Blink bit              }
@SetBlinkBit:
              OUT    DX,AL             { Rewrite Mode control register    }
END;

Procedure InputNums(var Lne : String;Chars : Byte;AllowZero : Boolean);
Var StartedX,X,Y,Counter : Byte;
    CH       : Char;
    P        : String;
    Done     : Boolean;
    Lower : Byte;
Begin
asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}
P := '';
Counter := 0;
StartedX := WhereX;
For X := 1 to Chars do Write(' ');
GotoXy(StartedX,WhereY);
Done := False;
Repeat
 X := WhereX;
 Y := WhereY;
 MemW[$0000:$041C] := MemW[$0000:$041A];
 CH := Readkey;
 If Allowzero then Lower := 48 else Lower := 49;
 If CH = #8 then If Counter > 0 then
                  Begin
                   GotoXy(X-1,Y);Write(' ');
                   GotoXy(X-1,Y);Delete(P,Length(P),1);
                   Dec(Counter);
                  End;
 If CH = #13 then Done := True;
 If CH = #27 then
             Begin
              P := 'Aborted';
              Done := True;
             End;
 If Counter < Chars then
     If (Ord(CH) < 58) and (Ord(CH) > Lower-1) then
             Begin
              Inc(Counter);
              P := P+(CH);
              Write(CH);
             End;
 Until (Done = True);
 Lne := P;
 GotoXy(StartedX,WhereY);
 For X := 1 to Chars do Write(' ');
 If Lne <> 'Aborted' then
  Begin
   GotoXy(StartedX,WhereY);
   Write(Lne);
  End;
End;

Procedure PipeWrite(S : String;Colors : Boolean);
Var X,Code : Byte;
    Error  : Integer;
    FORE,BACK:bYTE;
Begin
  Fore := 7;Back := 0;
  For X := 1 to Length(S) do BEGIN
  If S[X] = '|' then
       if s[x+1]='B' then begin
                          {io.back(strtoint(s[x+1]));}
                          TEXTBACKGROUND(VALU(S[X+2]));
                          inc(x,2);
                          end
                          else
   Begin

    Val(Copy(S,X+1,2),Code,Error);
    If Error = 0 then
     Begin
      If Code < 16 then Fore := Code else Back := Code-16;
      If X+2 > Length(S) then Inc(X,1) else Inc(X,2);
      {AnsiColor(Back shl 4 + Fore);}
      TEXTCOLOR(Back shl 4 + Fore);
     End else write(S[X]);
   End else Write(S[X])
 End;
END;
Procedure Uncrunch(var Addr1,Addr2; BlkLen:Integer);
Begin
  Inline (
    $1E/$C5/$B6/ADDR1/$C4/$BE/ADDR2/$8B/$8E/BLKLEN/$E3/$5B/$8B/$D7/
    $33/$C0/$FC/$AC/$3C/$20/$72/$05/$AB/$E2/$F8/$EB/$4C/$3C/$10/
    $73/$07/$80/$E4/$F0/$0A/$E0/$EB/$F1/$3C/$18/$74/$13/$73/$19/
    $2C/$10/$02/$C0/$02/$C0/$02/$C0/$02/$C0/$80/$E4/$8F/$0A/$E0/
    $EB/$DA/$81/$C2/$A0/$00/$8B/$FA/$EB/$D2/$3C/$1B/$72/$07/$75/$CC/
    $80/$F4/$80/$EB/$C7/$3C/$19/$8B/$D9/$AC/$8A/$C8/$B0/$20/$74/$02/
    $AC/$4B/$32/$ED/$41/$F3/$AB/$8B/$CB/$49/$E0/$AA/$1F);
End;

Procedure InputLn(var Lne : String;Chars:Byte;Caps:Boolean;Allcaps:Boolean;Start : String);
Var
 StartedX,Counter,OldAttr : Byte;
 CH   : Char;
 P    : String;
 Done : boolean;
 X : Byte;
 Fore,Back : Byte;
 ch1,ch2 : char;
 Position : Byte;
Begin
 OldAttr  := Textattr;
 Fore := Textattr and $0f;
 Back := (Textattr and $f0) shr 4;
 StartedX := WhereX;
 P        := Start;
 Counter  := Length(start);
 asm mov ah,1; mov ch,6; mov cl,7;int 10h; end; {Yes Cursor}
 Done := False;
 QWrite(StartedX,WhereY,Padstring(P,Chars),Fore,Back,80);
 GotoXy(StartedX,WhereY);
Repeat
 MemW[$0000:$041C] := MemW[$0000:$041A];
 Qwrite(StartedX,WhereY,Padstring(P,Chars),Fore,Back,80);
 GotoXy(StartedX+Counter,WhereY);
 ch1 := #0;ch2 := #0;
 Ch1 := Readkey;If Ch1 = #0 then Ch2 := Readkey;
 Case CH1 of
  #8 : If Counter > 0 then
        Begin
         Delete(P,Length(P),1);
         Dec(Counter);
        End;
 #13 : Done := True;
 #27 : Begin
        P := 'Aborted';
        Done := True;
       End;
 #32..#126 : If Counter < Chars then
              Begin
               Inc(Counter);
               If Caps then If (P[Counter-1] = #0) or (P[Counter-1]=#32) then CH := Upcase(CH1);
               If Allcaps then CH := Upcase(CH1);
               P := P + (CH1);
              End;
     End;
 Case Ch2 of
  #83 : Begin P := '';Counter := 0;End;
 End;
 Until Done = True;
 Lne := P;
 Textattr := 7;
 QWrite(StartedX,WhereY,PAdstring('',Chars),Fore,Back,80);
 If Lne <> 'Aborted' then Begin
                           QWrite(StartedX,WhereY,Padstring(Lne,Chars),Fore,Back,80);
                          End;
 Textattr := OldAttr;
End;

Procedure WaitRetrace; assembler;
asm
 mov dx,3DAh
 @l1: in al,dx;and al,08h;jnz @l1
 @l2: in al,dx;and al,08h;jz  @l2
end;

Procedure FastMove(VAR source;VAR dest;numToMove : WORD);
Begin
 Inline($8C/$DA/$C5/$B6/>SOURCE/$C4/$BE/>DEST/$8B/$8E/>NUMTOMOVE);
 Inline($39/$FE/$72/$08/$FC/$D1/$E9/$73/$11/$A4/$EB/$0E/$FD/$01/$CE);
 Inline($4E/$01/$CF/$4F/$D1/$E9/$73/$01/$A4/$4E/$4F/$F2/$A5/$8E/$DA);
End;

procedure MovW(var source,dest; num: word); assembler;
asm
 push ds;les di,[dest];lds si,[source];mov cx,[num];rep movsw;pop ds
end;

Procedure qwrite(x, y : byte; s : string; f, b : byte;CharsperRow : Word);
Var
  Cnter,Attrib  : Word;
  VidPtr : ^Word;
Begin
  attrib := swap((b shl 4) + f);
  vidptr := ptr($b800,2*(CharsPerRow*pred(y)+pred(x)));
  If lastmode = 7 then dec(longint(vidptr), $08000000);
  For cnter := 1 to length(s) do
  Begin
   vidptr^ := attrib or byte (s[cnter]);
   inc(vidptr);
  End;
End;

Procedure Beep(Freq,Dely : Word);
Begin
 Sound(Freq);
 Delay(Dely);
 Nosound;
End;

Function Yesno(unlit,lit : Byte) : Boolean;
Var X,Y : Byte;
    CH : Char;
    Yes : Boolean;
Label GetaKey,Ending;
Begin
X := WhereX;
Y := WhereY;
asm mov ah,1; mov cx,2000h;Int 10h end; {No Cursor}
GotoXy(X,Y);
Textattr := Lit;Write(' Yes ');
Textattr := Unlit;Write(' No ');
GotoXy(X,Y);
Yes := True;
While not (CH in['Y','N',#13,#27]) do
Begin
 CH := Readkey;If CH = #0 then CH := Readkey;CH := Upcase(CH);
 If CH in[#75,'Y'] then Yes := True;
 If CH in[#77,'N',#27] then Yes := False;
 GotoXy(X,Y);
 If Yes then Begin
              Textattr := lit;Write(' Yes ');
              Textattr := unlit;Write(' No ');
             End
        else Begin
              Textattr := unlit;Write(' Yes ');
              Textattr := lit;Write(' No ');
             End;
End;
Textcolor(7);Textbackground(0);
Yesno := Yes;
End;

Procedure Row_Clear;
Const Lines : Array[1..25] of Byte =
(1,3,5,7,9,11,13,15,17,19,21,23,25,24,22,20,18,16,14,12,10,8,6,4,2);
Var X : Byte;
Begin
 For X := 1 to 25 do Begin
                      GotoXy(1,Lines[X]);
                      ClrEol;
                      Delay(50);
                     End;
End;

Procedure ClearScreen;Assembler;
asm
 cld;
 mov ax,$b800;
 mov es,ax;
 xor di,di;
 xor ah,ah;
 mov cx,2000;
 rep stosw
end;

Procedure Clear_Column(Column : Byte);
Var X : Byte;
Begin
 For X := 1 to 25 do
   Begin
    GotoXy(Column,X);
    If Column < 80 then Write(#0);
   End;
End;

Procedure Column_Clear;
Const Column : Array[1..80] of Byte =
 (1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,
  53,55,57,59,61,63,65,67,69,71,73,75,77,79,80,78,76,74,72,70,68,66,64,62,
  60,58,56,54,52,50,48,46,44,42,40,38,36,34,32,30,28,26,24,22,20,18,16,14,
  12,10,8,6,4,2);
var P : Byte;
Begin
 For P := 1 to 160 do
 Begin
  Clear_Column(Column[P]);
  Delay(5);
 End;
End;

Procedure Close_Vertical;
Const Column : Array[1..80] of Byte =
 (1,80,2,79,3,78,4,77,5,76,6,75,7,74,8,73,9,72,10,71,11,70,12,69,13,
 68,14,67,15,66,16,65,17,64,18,63,19,62,20,61,21,60,22,59,23,58,24,57,
 25,56,26,55,27,54,28,53,29,52,30,51,31,50,32,49,33,48,34,47,35,46,36,
 45,37,44,38,43,39,42,40,41);
Var X : Byte;
Begin
 For X := 1 to 80 do Begin
                      Clear_Column(Column[X]);
                      Delay(5);
                     End;
End;

Procedure Close_Horizontal;
Const Row : Array[1..25] of Byte =
 (1,25,2,24,3,23,4,22,5,21,6,20,7,19,8,18,9,17,10,16,11,15,12,14,13);
Var P : Byte;
Begin
For P := 1 to 25 do Begin
                     GotoXy(1,Row[P]);
                     ClrEol;
                     Delay(10);
                    End;
End;

Function Center(Str : String) : Byte;
Begin
 Center := 40 - (length(Str) div 2);
End;

Function GetBitA(var a;Bit:Word):Boolean;assembler;
Const Bits:array[0..7] of Byte = ($1,$2,$4,$8,$10,$20,$40,$80);
asm
 Les di,a
 Mov si,bit
 Mov bx,si
 And si,07h
 Shr bx,03h
 Mov al,Byte(Bits[si])
 And al,es:[di+bx]
end;

Procedure InvertBitA(var a;Bit:Word);assembler;
Const Bits:array[0..7] of Byte = ($1,$2,$4,$8,$10,$20,$40,$80);
asm
  Les di,a
  Mov si,bit
  Mov bx,si
  And si,07h
  Shr bx,03h
  Mov al,Byte(Bits[si])
  Xor es:[di+bx],al
end;

Procedure PulltheBars;
var Y,X : Byte;
Begin
 For X := 1 to 80 do
  Begin
   WaitRetrace;
   For Y := 0 to 12 do
    Begin
     Mem[$b800:0000+(Y*2*160)+158] := 0;
     Mem[$b800:0000+(Y*2*160)+159] := 0;
     Mem[$b800:0000+((Y*2+1)*160)] := 0;
     Mem[$b800:0000+((Y*2+1)*160)+1] := 0;
     Fastmove(Mem[$b800:0000+(Y*2*160)+2],Mem[$b800:0000+(Y*2*160)],160-2);
     Fastmove(Mem[$b800:0000+((Y*2+1)*160)],Mem[$b800:0000+((Y*2+1)*160)+2],160-2);
    End;
 End;
End;

Procedure SlideLeft;
Var Y,X : Byte;
Begin
For X := 1 to 80 do
Begin
WaitRetrace;
For Y := 0 to 25 do
Begin
 Mem[$b800:0000+(Y*160)+158] := 0;
 Mem[$b800:0000+(Y*160)+159] := 0;
 Fastmove(Mem[$b800:0000+(Y*160)+2],Mem[$b800:0000+(Y*160)],160-2);
End;
End;
End;

Procedure SlideRight;
Var Y,X : Byte;
Begin
For X := 1 to 80 do
Begin
WaitRetrace;
For Y := 0 to 25 do
Begin
 Mem[$b800:0000+(Y*160)]   := 0;
 Mem[$b800:0000+(Y*160)+1] := 0;
 Fastmove(Mem[$b800:0000+(Y*160)],Mem[$b800:0000+(Y*160)+2],160-2);
End;
End;
End;

Procedure SlideUp;
Var X : Byte;
Begin
 Fillword(Mem[$b800:160*25-160],80,0);
 For X := 1 to 25 do
  Begin
   WaitRetrace;
   Fastmove(Mem[$b800:0160],Mem[$b800:0000],3840);
  End;
End;

Procedure SlideDown;
Var X : Byte;
Begin
 FillWord(Mem[$b800:0000],80,0);
 For X := 1 to 25 do
  Begin
   WaitRetrace;
   Fastmove(Mem[$b800:0000],Mem[$b800:0160],3840);
  End;
End;

function base_free : longint;
begin;
  base_free := MemAvail;
end;

Function IsVesa:Boolean;
Var Regs : Registers;
Begin
  regs.ax:=$4F03;
  Intr($10,regs);
  IsVesa:=(regs.al=$4F);
End;

begin
End.