Power-Programmierung/CD1.mdf/pascal/library/dos/grafik/dc/svga.pas

Pascal/Delphi Source File | 1992-10-21 | 35.8 KB | 1,330 lines

{
  Copyright 1992 by Digital Crime.

  All rights reserved.

  Permission to use, copy, modify, and distribute this software and its
  documentation for any purpose and without fee is hereby granted,
  provided that the above copyright notice appear in all copies and that
  both that copyright notice and this permission notice appear in
  supporting documentation, and that the name of the Digital Crime
  not be used in advertising or publicity pertaining to distribution
  of the software without specific, written  prior permission.

  DIGITAL CRIME DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS
  SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
  AND FITNESS, IN NO EVENT SHALL DIGITAL CRIME BE LIABLE FOR ANY SPECIAL,
  INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
  NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
  WITH THE USE OR PERFORMANCE OF THIS  SOFTWARE.

  [e-mail]   Chandi.
  [e-mail]   Ed.



}
{$R-}

Unit SVGA;

{ This unit enables TP programs to utilize SVGA graphics. }
{ Nine types of cards are supported however not all have  }
{ tested.  Also included is a SVGA mouse driver.          }
{ References  - Programmer's Guide to the EGA & VGA Cards ( 2nd Ed.) }
{               Richard F. Ferraro,  Addison-Wesley, 1990.           }
{               ISBN 0-201-57025                                     }
{             - Finn Theogersen  [e-mail]                }
{             - Graphics Programming in Turbo Pascal 6.0             }
{               Ben Ezzell, Addison-Wesley, 1991                     }
{               ISBN 0-201-58119-1                                   }
{             - Advanced Graphics Programming in Turbo Pascal        }
{               Roger T. Stevens and Christopher D. Watkins,         }
{               Prentice Hall, M & T Books, 1991.                    }
{               ISBN 0-13-367145-3                                   }

INTERFACE

const
   ButtonL = 0; ButtonR = 1; ButtonM = 2;
   OFF      = 0;  ON       = 1;

Type
  RGB = record
        Red, Grn, Blu : byte
        end;
  PaletteRegister = array[0..255] of RGB;
  SetTypes = ( FutureFont, StandardFont );
  ResType = ( SVGAMED, SVGAHIGH );  { SVGAHIGH not installed as yet }
  Position = record
               BtnStatus,
               opCount,
               XPos, YPos : integer;
             end;

  EventRec = record
               Event,
               BtnStatus,
               XPos, YPos : word;
             end;

var  Color : PaletteRegister;
     Bytes_per_Line, GetMaxX, GetMaxY : integer;
     mEvent : EventRec;
     PresentSeg : byte;

procedure SetMode( Mode : Restype );
  { Sets Graphics card to desired mode }
procedure LoadWriteBank( Segment : byte );
  { Loads particular bank for read/write operations }
procedure Plot( x, y : integer; Color : byte );
  { Plots a point to screen }
procedure SetColor( PalNum: byte; Hue : RGB );
  { Sets Color of a particular pallette }
function  GetPixel( x, y : integer ) : byte;
  { Returns color of a pixel }
procedure SetPalette( Hue : PaletteRegister );
  { Sets all 256 pallette registers to desired pallette }
procedure CyclePalette;
  { Rotates all colors in the pallette in repetitive cycle }
procedure Circle( x, y, Radius : word; Color : byte );
  { Draws a circle }
procedure Line( xx1, yy1, xx2, yy2 : integer; Color : byte );
  { Draws a line }
procedure Rectangle( x1, y1, x2, y2 : word; Color : byte );
  { Draws a rectangle outline i.e not solid }
procedure RectFill( x1, y1, x2, y2 : integer; Color : byte );
  { Draws a solid Rectangle }
procedure ClearPort( x1, y1, x2, y2 : integer );
  { Clears a Section of the screen }
procedure OutTextXY( x, y : integer; word : string );
  { Writes text to screen at point X, Y }
procedure LoadFont( CharSetName: SetTypes );
  { Loads a particular Font for use }
procedure SetFont( Font : SetTypes );
  { If two or more fonts are in memory this allows you to choose one }
procedure SetFontColor( Color, BackCol : byte; Trans : boolean );
  { Set forground & background color of text & transparent background or not }
  { i.e write background to screen or skip it and only write letter          }
procedure LoadPalette( PaletteName : string );
  { Loads a particular pallette from disk }
procedure ExitGraphics;
  { Exits SVGA Graphics and returns to normal text mode }

type
   GenMouse = object
      procedure SetAccel( threshold : integer );
        { Set Acceleration of mouse }
      procedure Getposition( var BtnStatus, XPos, YPos : integer );
        { Gets the Position of the mouse and returns button status }
      procedure QueryBtnDn( button : integer; var mouse : Position );
        { Checks if queried button was pressed }
      procedure QueryBtnUp( button : integer; var mouse : Position );
        { Checks if queried button is released }
      procedure ReadMove( var XMove, YMove : integer );
        { Reports absolute mouse movement since last call to ReadMove }
      procedure Reset( var Status : boolean; var BtnCount : integer );
        { Resets the mouse to default conditions }
      procedure SetRatio( horPix, verPix : integer );
        { Sets speed of mouse }
      procedure SetLimits( XPosMin, YPosMin, XPosMax, YPosMax : integer );
        { Creates View Port for which mouse can operate in }
      procedure SetPosition( XPos, YPos : integer );
        { Puts mouse to desired point on screen }
   end;

  GraphicMouse = object( GenMouse )
    procedure Initialize;
      { Sets default conditons for graphics mouse }
    procedure Show( ShowMouse : boolean );
      { Either shows or hides the graphics mouse }
    procedure CheckMouse;
      { Checks if mouse has been moved since last call and moves mouse accordingly }
    procedure ExitSVGA;
      { Exits Graphics mouse and resets it back to text mode }
  end;


IMPLEMENTATION

Uses Dos, Crt;

const White = 255;
      Black = 0;

type  FCharType = array[ 0..15, 0..12 ] of boolean;
      FCharSetType = array[ 0..95 ] of FCharType;
      SCharType = array[ 0..7, 0..9 ] of boolean;
      SCharSetType = array[ 0..95 ] of SCharType;
      CardType = ( AheadA, AheadB, ATI, ChipsTech, Everex, Genoa,
                   Paradise, Trident, Tseng3000, Tseng4000, Video7 );
      ImagePtrType = ^ImageType;
      ImageType = array[ 0..120, 0..120 ] of byte;
      NameType = string[30];

var
  XRes, YRes, X, Y, OldX, OldY : integer;
  regs : registers;
  Future : ^FCharSetType;
  Standard : ^SCharSetType;
  Width, Height, FontColor, BackGroundColor : byte;
  PresentSet : SetTypes;
  Transparent, Sused, Fused : boolean;
  Card : CardType;
  MP, ColOld : array[ 0..3, 0..3 ] of byte;

function Ahead : NameType;

  begin
    Portw[$3CE] := $200F;
    if Port[$3CF] = $20 then Ahead := 'Ahead A'
      else if Port[$3CF] = $21 then Ahead := 'Ahead B'
        else Ahead := 'False';
  end;

function AnATI : NameType;

  var s : NameType;
      Temp : string;

  begin
    s[0] := #9;
    move(mem[$C000:$31],s[1],9);
    if s = '761295520'then
      begin
        Temp := 'ATI';
        if memw[$C000:$40] = $3331 then Temp := Temp + ' Super VGA';
        Regs.AH := $12;
        Regs.BX := $5506;
        Regs.AL := $55;
        Regs.BP := $FFFF;
        Regs.SI := $0;
        intr( $10, Regs );
        if Regs.BP = $FFFF then Temp := Temp + ' Revision 1'
          else Temp := Temp + ' Revision 2/3';
        AnATI := Temp;
      end
    else AnATI := 'False';
  end;

function AChipsTech : Nametype;

  var OldValue, Value : byte;
      Temp : string;

  begin
    Port[$3C3] := Port[$3C3] or 16;
    if Port[$104] = $A5 then
      begin
        Temp:= 'Chips & Technologies';
        Port[$3C3] := Port[$3C3] and $EF;
        Port[$3D6] := 0;
        case Port[$3D7] shr 4 of
          2 : Temp := Temp + ' 82c455';
          3 : Temp := Temp + ' 82c453';
          5 : Temp := Temp + ' 82c456';
          1 : begin
                Port[$3D6] := $3A;
                OldValue := Port[$3D7];
                Port[$3D7] := $AA;
                Value := Port[$3D7];
                Port[$3D7] := OldValue;
                if Value = $AA then Temp := Temp + ' 82c452'
                  else Temp := Temp + ' 82c451';
              end;
          end;
        AChipsTech := Temp;
      end
    else AChipsTech := 'False';
  end;

function AnEverex : NameType;

  var Value : byte;
      s : NameType;

  begin
    Regs.AX := $7000;
    Regs.BX := 0;
    intr( $10, Regs );
    if Regs.AL = $70 then
      begin
        Value := Regs.DX shr 4;
        if Value = $678 then AnEverex := 'Everex Ev678'
          else if Value = $236 then AnEverex := 'Everex Ev236'
            else begin
                   str( Value, s );
                   AnEverex := 'Everex Ev'+ s;
                 end;
      end
    else AnEverex := 'False';
  end;

function AGenoa : Nametype;

  begin
    if (meml[$C000:mem[$C000:$37]] and $FFFF00FF) = $66990077 then
      begin
        case mem[$C000:mem[$C000:$37] + 1] of
          $33, $55 : AGenoa := 'Tseng ET3000';
               $22 : AGenoa := 'Genoa 6100';
                 0 : AGenoa := 'Genoa 6200/6300';
               $11 : AGenoa := 'Genoa 6400/6600';
          end;
      end
    else AGenoa := 'False';
  end;

function AParadise : NameType;

  var OldValue, NewValue, New1, New2 : byte;
      Base : word;
      Temp : string;

   begin
     if meml[$C000:$7D] = $3D414756 then
       begin
         Temp := 'Paradise';
         if odd(Port[$3CC]) then Base:= $3D4
           else Base := $3B4;
         Port[Base] := $2B;  OldValue := Port[Base+1];
         Port[Base+1] := $AA; NewValue := Port[Base+1];
         Port[Base+1] := OldValue;
         if NewValue <> $AA then Temp := Temp + ' PVGA1A'
           else
             begin
               Port[$3C4] := $12; OldValue := Port[$3C5];
               Port[$3C5] := OldValue and $BF; New1 := Port[$3C5] and 64;
               Port[$3C5] := OldValue or $40;  New2 := Port[$3C5] and 64;
               Port[$3C5] := OldValue;
               if (New1 <> 0) or (New2 = 0) then Temp := Temp + ' WD90C00'
                 else
                   begin
                     Port[$3C4] := $10; OldValue := Port[$3C5];
                     Port[$3C5] := OldValue and $FB; New1 := Port[$3C5] and 4;
                     Port[$3C5] := OldValue or 4;    New2 := Port[$3C5] and 4;
                     Port[$3C5] := OldValue;
                     if (New1 <> 0) or (New2 = 0) then Temp := Temp + ' WD90C10'
                       else Temp := Temp + ' WD90C11';
                   end;
             end;
         AParadise := Temp;
       end
     else AParadise := 'False';
   end;

function ATrident : NameType;

   var OldValue, Value : byte;
       Temp : string;

   begin
     Port[$03C4] := $E;
     OldValue := Port[$03C5];
     Port[$03C5] := 0;
     Value := Port[$03C5] AND $F;
     Port[$03C5] := OldValue;
     if Value = $2 then
       begin
         Temp := 'Trident';
         Port[$3C4] := 11;
         if Port[$3C5] >= 3 then Temp := Temp + ' 8900/9000'
           else Temp := Temp + ' 8800';
         ATrident := Temp;
       end
     else ATrident := 'False';
  end;

function ATseng : NameType;

  var OldValue, NewValue, Value : byte;
      Base : word;
      Temp : string;

  begin
    OldValue := Port[$3CD];
    Port[$3CD] := $55;
    NewValue := Port[$3CD];
    Port[$3CD] := OldValue;
    if NewValue = $55 then
      begin
        Temp := 'Tseng';
        if odd( Port[$3CC] ) then Base := $3C4
          else Base := $3B4;
        Port[Base] := $33; OldValue := Port[Base+1];
        NewValue := OldValue xor 15;
        Port[Base+1] := NewValue;
        Value := Port[Base+1];
        Port[Base+1] := OldValue;
        if Value = NewValue then Temp := Temp + ' ET4000'
          else Temp := Temp + ' ET3000';
        ATseng := Temp;
      end
    else ATseng := 'False';
  end;

function AVideo7 : NameType;

  var Value, OldValue, NewValue : byte;
      Base : word;
      Temp : string;

  begin
    if odd( Port[$3CC] ) then Base := $3D4
      else Base := $3B4;
    Port[Base] := 12; OldValue := Port[Base+1];
    Port[Base+1] := $55; NewValue := Port[Base+1];
    Port[Base] := $1F; Value := Port[Base+1];
    Port[Base] := 12; Port[Base+1] := OldValue;
    if Value = byte( $55 xor $EA ) then
      begin
        Temp := 'Video7';
        Port[$3C4] := $8E;
        case Port[$3C5] of
          $80..$FF : Temp := Temp + ' VEGA VGA';
          $70..$7F : Temp := Temp + ' V7VGA FASTWRITE/VRAM';
          $50..$59 : Temp := Temp + ' V7VGA Version 5';
          $41..$49 : Temp := Temp + ' 1024i';
        end;
        AVideo7 := Temp;
      end
    else AVideo7 := 'False';
  end;

procedure SetMode( Mode : ResType );

  var ModeNum : byte;

  begin
    TextColor( LightRed );  writeln; writeln;
    if Ahead <> 'False' then
      begin
        if Mode = SVGAMED then ModeNum := $61;
        if Ahead = 'Ahead A' then Card := AheadA
          else Card := AheadB;
        write( Ahead + ' Card Detected' );
      end
    else if AnATI <> 'False' then
      begin
        if Mode = SVGAMED then ModeNum := $62;
        Card := ATI;
        write( AnATI + 'Card Detected' );
      end
    else if AChipsTech <> 'False' then
      begin
        if (AChipsTech = 'Chips & Technologies 82c452') or
           (AChipsTech = 'Chips & Technologies 82c453') then
           begin
             if Mode = SVGAMED then ModeNum := $79;
             Card := ChipsTech;
             write( AChipsTech + ' Card Detected' );
           end
        else
          begin
            write( AChipsTech + ' Card does not support 640*480 256 Color Mode ' );
            Halt( 1 );
          end
      end
    else if AnEverex <> 'False' then
      begin
        if Mode = SVGAMED then ModeNum := $30; { ??? How about Trident }
        if (AnEverex = 'Everex Ev678') or (AnEverex = 'Everex Ev236') then
          Card := Trident   { 678, 236 Chips use Trident }
        else Card := Everex;
        write( AnEverex + ' Card Detected' );
      end
    else if AGenoa <> 'False' then
      begin
        if AGenoa = 'Tseng 3000' then
          begin
            if Mode = SVGAMED then ModeNum := $2E;
            Card := Tseng3000;
          end
        else
          begin
            if Mode = SVGAMED then ModeNum := $5C;
            Card := Genoa;
          end;
        write( AGenoa + ' Card Detected' );
      end
    else if AParadise <> 'False' then
      begin
        if Mode = SVGAMED then ModeNum := $5F;
        Card := Paradise;
        write( AParadise + ' Card Detected' );
      end
    else if ATrident <> 'False'then
      begin
        if Mode = SVGAMED then ModeNum := $5D;
        Card := Trident;
        write( ATrident + ' Card Detected' );
      end
    else if ATseng <> 'False' then
      begin
        if Mode = SVGAMED then ModeNum := $2E;
        if ATseng = 'Tseng ET3000' then Card := Tseng3000
          else Card := Tseng4000;
        write( ATseng + ' Card Detected' );
      end
    else if AVideo7 <> 'False' then
      begin
        if Mode = SVGAMED then ModeNum := $67;
        Card := Video7;
        write( AVideo7 + ' Card Detected' );
      end
    else
      begin
        write( 'Graphics card Unrecognizable......' );
        Halt( 1 );
      end;
    Delay( 500 );
    if Mode = SVGAMED then
      begin
        GetMaxX := 639;
        GetMaxY := 479;
        Bytes_per_line := 640;
      end;
    if Card <> Video7  then
      begin
        Regs.AH := 0;
        Regs.AL := ModeNum;
        intr( $10, Regs );
      end;
    if Card = ATI then                { Certain cards have to be  }
      asm                             { initialized before use    }
        push es
        push bx
        mov ax, 0c000h
        mov es, ax
        mov bx, 10h
        mov dx, es:[bx]
        pop bx
        pop es
        mov al, 0beh
        out dx, al
        inc dl
        in al, dx
        mov ah, al
        and ah, 0f7h
        dec dl
        mov al, 0beh
        out dx, ax
      end;
      if Card = ChipsTech then
        asm
          mov dx, 3d6h
          mov al, 0bh
          out dx, al
          in al, dx
          and al, 0fdh
          out dx, al
        end;
      if Card = Paradise then
        asm
          mov dx, 3ceh
          mov al, 0fh
          mov ah, 05h
          out dx, ax
          add dx, 4
          mov al, 29h
          mov ah, 85h
          out dx, ax
          mov dx, 3c4h
          mov al, 06h
          mov ah, 48h
          out dx, ax
          mov dx, 3c4h
          mov al, 11h
          out dx, al
          inc dx
          in  al, dx
          and al, 7fh
          out dx, al
          mov dx, 3ceh
          mov al, 0bh
          out dx, al
          inc dx
          in  al, dx
          and al, 0f7h
          out dx, al
        end;
      if Card = Video7 then
         asm
           mov bx, 67h
           mov ax, 6f05h
           int 10h
           mov dx, 3c4h
           mov al, 6
           mov ah, 0eah
           out dx, ax
         end;
  end;

procedure LoadWriteBank( Segment : byte );

{ This is the main problem with SVGA graphics. }
{ Each card manufacturer have their own way of }
{ loading banks so each type of card must be   }
{ handled seperatly.                           }

  begin
    PresentSeg := Segment;
    if Card = Trident then
        asm
          mov bl, Segment
          mov dx, 3c4h
          mov al, 0eh
          xor bl, 02
          mov ah, bl
          out dx, ax
        end
    else if Card = Tseng3000 then
        asm
          mov bl, Segment
          mov dx, 3cdh
          in  al, dx
          and al, 0f8h
          and bl, 07h
          or  al, bl
          out dx, al
        end
    else if Card = Tseng4000 then
        asm
          mov bl, Segment
          mov dx, 3cdh
          in  al, dx
          and al, 0f0h
          and bl, 0fh
          or  al, bl
          out dx, al
        end
      else if Card = Paradise then
        asm
          mov bl, Segment
          mov dx, 3ceh
          mov al, 09h
          mov ah, bl
          shl ah, 1
          shl ah, 1
          shl ah, 1
          shl ah, 1
          out dx, ax
        end
      else if Card = Genoa then
        asm
          mov bl, Segment
          mov dx, 3c4h
          mov al, 06h
          out dx, al
          inc dx
          in  al, dx
          and al, 0c7h
          and bl, 07h
          shl bl, 1
          shl bl, 1
          shl bl, 1
          or  al, bl
          out dx, al
        end
      else if Card = ChipsTech then
        asm
          mov bl, Segment
          mov dx, 3d6h
          mov al, 10h
          mov ah, bl
          shl ah, 1
          shl ah, 1
          out dx, ax
        end
      else if Card = ATI then
        asm
          mov bl, Segment
          push es
          push bx
          mov ax, 0c000h
          mov es, ax
          mov bx, 10h
          mov dx, es:[bx]
          pop bx
          pop es
          mov al, 0b2h
          out dx, al
          inc dl
          in al, dx
          mov ah, al
          and ah, 0e1h
          shl bl, 1
          or ah, bl
          mov al, 0b2h
          dec dl
          out dx, ax
        end
      else if Card = Video7 then
      { This is for the V7VGA Chip Versions 1-3 }
      { Version 4 is different }
        asm
          mov bl, Segment
          mov dx, 3c4h
          mov ah, bl
          and ah, 1
          mov al, 0f9h
          out dx, ax

          mov ah, bl
          and ah, 2
          shl ah, 1
          shl ah, 1
          shl ah, 1
          shl ah, 1
          mov dx, 3cch

          in  al, dx
          and al, 0dfh
          mov dx, 3c2h

          or  al, ah
          out dx, al

          mov dx, 3c4h
          mov al, 0f6h
          out dx, al
          inc dx
          in  al, dx

          mov ah, al
          and ah, 0fch
          shr bl, 1

          shr bl, 1
          and bl, 3
          or  ah, bl
          mov al, ah
          out dx, al
        end;
  end;

procedure Plot( x, y : integer; Color : byte );

  var Segment : byte;

  begin
    if (y = 102) AND (x < 256) then Segment := 0
         else if (y = 204) AND (x < 512) then Segment := 1
          else if (y = 307) AND (x < 128) then  Segment := 2
           else if (y = 409) AND (x < 384) then Segment := 3
            else if y < 102 then Segment := 0
             else if y < 204 then Segment := 1
              else if y < 307 then Segment := 2
               else if y < 409 then Segment := 3
                else Segment := 4;
   if Segment <> PresentSeg then LoadWriteBank( Segment );
    asm
      mov ax, Bytes_per_Line
      mov bx, y
      mul bx
      add ax, x
      mov di, ax
      mov ax, 0a000h
      mov es, ax
      mov al, Color
      mov es:[di], al
    end;
  end;

procedure SetColor( PalNum: byte; Hue : RGB );

  var reg : registers;

  begin
    Color[ PalNum ] := Hue;
    with reg do
      begin
        AX := $1010;
        BX := PalNum;
        CH := Hue.Grn;
        CL := Hue.Blu;
        DH := Hue.Red;
      end;
    intr( $10, reg );
  end;

function GetPixel( x, y : integer ) : byte;

  var Segment : byte;

  begin
    if (y = 102) AND (x < 256) then Segment := 0
         else if (y = 204) AND (x < 512) then Segment := 1
          else if (y = 307) AND (x < 128) then  Segment := 2
           else if (y = 409) AND (x < 384) then Segment := 3
            else if y < 102 then Segment := 0
             else if y < 204 then Segment := 1
              else if y < 307 then Segment := 2
               else if y < 409 then Segment := 3
                else Segment := 4;
    if Segment <> PresentSeg then LoadWriteBank( Segment );
    Regs.AX := 3328;
    Regs.DX := y;
    Regs.CX := x;
    Intr( $10, Regs );
    GetPixel := Regs.AX AND 255;
  end;

procedure SetPalette( Hue : PaletteRegister );

  begin
    Color := Hue;
    with Regs do
      begin
        AX := $1012;
        BX := 0;
        CX := 256;
        ES := Seg( Hue );
        DX := Ofs( Hue );
      end;
    intr( $10, Regs );
  end;

procedure CyclePalette;

  var
    i   : byte;
    Tmp : RGB;

  begin
    Tmp := Color[1];
    for i := 2 to 251 do
        Color[i-1] := Color[i];
    Color[251] := Tmp;
    SetPalette( Color )
  end;

procedure Swap( var First, Second : integer );

  var
    temp : integer;

  begin
    temp   := first;
    first  := second;
    second := temp
  end;


procedure Circle( x, y, Radius : word; Color : byte );

  var
    a, af, b, bf, target, r2 : integer;

  begin
    target := 0;
    a := radius;
    b := 0;
    r2 := Sqr( radius );
    while a >= b do
      begin
        b := Round( Sqrt( r2 - sqr(a)));
        Swap( target, b );
        while b < target do
          begin
            af := (100*a) div 100;
            bf := (100*b) div 100;
            Plot( x+af, y+b, color );
            Plot( x+bf, y+a, color );
            Plot( x-af, y+b, color );
            Plot( x-bf, y+a, color );
            Plot( x-af, y-b, color );
            Plot( x-bf, y-a, color );
            Plot( x+af, y-b, color );
            Plot( x+bf, y-a, color );
            b := b + 1
          end;
        a := a - 1
      end
  end;

procedure Line( xx1, yy1, xx2, yy2 : integer; color : byte );

  var
    LgDelta, ShDelta, Cycle, LgStep, ShStep, Dtotal : integer;

  begin
    LgDelta := xx2 - xx1;
    ShDelta := yy2 - yy1;
    if LgDelta < 0 then
      begin
        LgDelta := -LgDelta;
        LgStep := -1
      end
     else
        LgStep := 1;
    if ShDelta < 0 then
      begin
        ShDelta := -ShDelta;
        ShStep := -1
      end
      else
        ShStep := 1;
    if ShDelta < LgDelta then
      begin
        Cycle := LgDelta shr 1;
        while xx1 <> xx2 do
          begin
            Plot( xx1, yy1, color );
            Cycle := Cycle + ShDelta;
            if Cycle > LgDelta then
              begin
                Cycle := Cycle - LgDelta;
                yy1 := yy1 + ShStep
              end;
            xx1 := xx1 + LgStep
          end;
        Plot( xx1, yy1, color )
      end
    else
      begin
        Cycle := ShDelta shr 1;
        Swap( LgDelta, ShDelta );
        Swap( LgStep, ShStep );
        while yy1 <> yy2 do
          begin
            Plot( xx1, yy1, color );
            Cycle := Cycle + ShDelta;
            if Cycle > LgDelta then
              begin
                Cycle := Cycle - LgDelta;
                xx1 := xx1 + ShStep
              end;
            yy1 := yy1 + LgStep
          end;
        Plot( xx1, yy1, color )
      end;
  end;

procedure Rectangle( x1, y1, x2, y2 : word; Color : byte );

  begin
    Line( x1, y1, x2, y1, Color );
    Line( x2, y1, x2, y2, Color );
    Line( x2, y2, x1, y2, Color );
    Line( x1, y2, x1, y1, Color );
  end;

procedure RectFill( x1, y1, x2, y2 : integer; Color : byte );

{ Special algorithm to speed up fill time }

  var i : integer;
      Segment : byte;

  begin
    if x2 < x1 then Swap( x1, x2 );
    if y2 < y1 then Swap( y1, y2 );
    repeat
      if (y1 = 102) OR (y1 = 204) OR (y1 = 307) OR (y1 = 409) then
        begin
          Line( x1, y1, x2, y1, Color );
          y1 := y1 + 1;
        end
      else
        begin
          if y1 < 102 then Segment := 0
            else if y1 < 204 then Segment := 1
              else if y1 < 307 then Segment := 2
                else if y1 < 409 then Segment := 3
                  else Segment := 4;
        if Segment <> PresentSeg then LoadWriteBank( Segment );
        i := x1;
          repeat
            asm
              mov ax, Bytes_per_Line
              mov bx, y1
              mul bx
              add ax, x1
              mov di, ax
              mov ax, 0a000h
              mov es, ax
              mov al, Color
              mov es:[di], al
            end;
          x1 := x1 + 1;
        until x1 > x2;
        x1 := i;
        y1 := y1 + 1;
      end;
    until y1 > y2;
  end;

procedure ClearPort( x1, y1, x2, y2 : integer );

  var i, j, Temp : integer;

  begin
    if y1 > y2 then Swap( y1, y2 );
    for i := 0 to 19 do
      for j := 0 to 23 do
        begin
          Temp := y1+i+j*20;
          if Temp <= y2 then
            RectFill( x1, Temp, x2, Temp, 0 );
        end;
  end;


procedure ExitGraphics;

  begin
    Sound(1300); Delay(200); NoSound;
    Regs.AH := 0;
    Regs.AL := 3;
    intr( $10, Regs );
    if Fused then dispose( Future );
    if Sused then dispose( Standard );
  end;

procedure OutTextXY( x, y : integer; word : string );

  var i, j, k, symbol : byte;
      LetterX, LetterY, xx, yy : integer;

  begin
    LetterX := x;
    LetterY := y;
    if PresentSet = FutureFont then
      begin
         for i := 1 to length( word ) do
           begin
             symbol := ord(word[i])-ord(' ');
             for j := 0 to Width do
               for k := 0 to Height do
                   if Future^[symbol][j,k] then
                         Plot( LetterX+j, LetterY+k, FontColor )
                   else if not Transparent then
                         Plot( LetterX+j, LetterY+k, BackGroundColor );
             LetterX := LetterX + Width + 2;
           end;
      end;
    if PresentSet = StandardFont then
      begin
         for i := 1 to length( word ) do
           begin
             symbol := ord(word[i])-ord(' ');
             for j := 0 to Width do
               for k := 0 to Height do
                   if Standard^[symbol][j,k] then
                         Plot( LetterX+j, LetterY+k, FontColor )
                   else if not Transparent then
                         Plot( LetterX+j, LetterY+k, BackGroundColor );
             LetterX := LetterX + Width + 2;
           end;
      end;
  end;

procedure LoadFont( CharSetName: SetTypes );

  var Sfil : file of SCharSetType;
      Ffil : file of FCharSetType;
      Color : byte;

  begin
    if CharSetName = FutureFont then
      begin
        GetMem( Future, 19968 );
        assign( Ffil, 'future.chr' );
        reset( Ffil );
        Read( Ffil, Future^ );
        Close( Ffil );
        Fused := True;
      end;
    if CharSetName = StandardFont then
      begin
        GetMem( Standard, 7680 );
        assign( Sfil, 'standard.chr' );
        reset( Sfil );
        Read( Sfil, Standard^ );
        Close( Sfil );
        Sused := True;
      end;
  end;

procedure SetFont( Font : SetTypes );

  begin
    if Font = FutureFont then
      begin
        Width := 15;
        Height := 12;
        PresentSet := FutureFont;
      end;
    if Font = StandardFont then
      begin
        Width := 7;
        Height := 9;
        PresentSet := StandardFont;
      end;
  end;

procedure SetFontColor( Color, BackCol : byte; Trans : boolean );
  begin
    FontColor := Color;
    BackGroundColor := BackCol;
    Transparent := Trans;
  end;

procedure LoadPalette( PaletteName : string  );

  var Fil : File of PaletteRegister;

  begin
    assign( fil, PaletteName );
    reset( fil );
    read( fil, Color );
    Close( fil );
    SetPalette( Color );
  end;

function Lower( n1, n2 : integer ) : integer;
   begin
      if n1 < n2 then Lower := n1
                 else Lower := n2;
   end;

function Upper( n1, n2 : integer ) : integer;
   begin
      if n1 > n2 then Upper := n1
                 else Upper := n2;
   end;

procedure MouseHandler( Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP : word );

   INTERRUPT;
   begin
      mEvent.Event     := AX;
      mEvent.BtnStatus := BX;
      mEvent.xPos      := CX;
      mEvent.yPos      := DX;
      inline( $8B/$E5/$5D/$07/$1F/$5F/$5E/$5A/$59/$5B/$58/$CB );
   end;

procedure GenMouse.Reset( var Status : boolean; var BtnCount : integer );
   begin
      regs.AX := $00;
      intr($33,regs);
      Status   := regs.AX <> 0;
      BtnCount := regs.BX;
   end;

procedure GenMouse.SetAccel( threshold : integer );
   begin
      regs.AX := $13;
      regs.DX := threshold;
      intr($33,regs);
   end;

procedure GenMouse.GetPosition( var BtnStatus, XPos, YPos : integer );
   begin
      regs.AX := $03;
      intr($33,regs);
      Btnstatus := regs.BX;
      XPos := X; YPos := Y;
   end;

procedure GenMouse.SetPosition( XPos, YPos : integer );
   begin
      regs.AX := $04;
      regs.CX := XPos;
      regs.DX := YPos;
      intr($33,regs);
   end;

procedure GenMouse.SetRatio( horPix, verPix : integer );
  begin
     regs.AX := $0F;
     regs.CX := horPix;
     regs.DX := verPix;
     intr($33,regs);
  end;

procedure GenMouse.QueryBtnDn( button : integer; var mouse : Position );
   begin
      regs.AX := $05;
      regs.BX := button;
      intr($33,regs);
      mouse.BtnStatus := regs.AX;
      mouse.opCount := regs.BX;
      mouse.XPos    := regs.CX;
      mouse.YPos    := regs.DX;
   end;

procedure GenMouse.QueryBtnUp( button : integer; var mouse : Position );
   begin
      regs.AX := $06;
      regs.BX := button;
      intr($33,regs);
      mouse.BtnStatus := regs.AX;
      mouse.opCount := regs.BX;
      mouse.XPos    := regs.CX;
      mouse.YPos    := regs.DX;
   end;

procedure GenMouse.SetLimits( XPosMin, YPosMin, XPosMax, YPosMax : integer );
   begin
      regs.AX := $07;
      regs.CX := Lower(XPosMin,XPosMax);
      regs.DX := Upper(XPosMin,XPosMax);
      intr($33,regs);
      regs.AX := $08;
      regs.CX := Lower(YPosMin,YPosMax);
      regs.DX := Upper(YPosMin,YPosMax);
      intr($33,regs);
   end;

procedure GenMouse.ReadMove( var XMove, Ymove : integer );
   begin
      regs.AX := $0B;
      intr($33,regs);
      XMove := regs.CX;
      Ymove := regs.DX;
   end;

procedure MousePlot( x, y : integer; Color : byte );

  var Segment : byte;

  begin
    if (y = 102) AND (x < 256) then Segment := 0
         else if (y = 204) AND (x < 512) then Segment := 1
          else if (y = 307) AND (x < 128) then  Segment := 2
           else if (y = 409) AND (x < 384) then Segment := 3
            else if y < 102 then Segment := 0
             else if y < 204 then Segment := 1
              else if y < 307 then Segment := 2
               else if y < 409 then Segment := 3
                else Segment := 4;
   LoadWriteBank( Segment );
    asm
      mov ax, Bytes_per_Line
      mov bx, y
      mul bx
      add ax, x
      mov di, ax
      mov ax, 0a000h
      mov es, ax
      mov al, Color
      mov es:[di], al
    end;
  end;

procedure MPlot( xx, yy : integer );

  var TX, TY, x, y : integer;

  begin
    for TY := 0 to 3 do
      begin
        y := yy + TY;
        if y < GetMaxY then
        for TX := 0 to 3 do
          begin
            x := xx + TX;
            if (MP[TX,TY] <> 0) AND (x < GetMaxX) then
                MousePlot( x, y, MP[TX,TY] );
          end;
      end;
  end;

procedure GraphicMouse.Show( ShowMouse : boolean );

  var i, j, x, y : integer;

  begin
    if ShowMouse then
      begin
        for i := 0 to 3 do
          for j := 0 to 3 do
            ColOld[ i, j ] := GetPixel( OldX + i, OldY + j );
        MPlot( OldX, OldY );
      end
    else
      for i := 0 to 3 do
        begin
          x := OldX + i;
          for j := 0 to 3 do
            begin
              y := OldY + j;
              MousePlot( x, y, ColOld[i,j] );
            end;
        end;
  end;

procedure GraphicMouse.CheckMouse;

  var XNew, YNew, i, j : integer;

  begin
    ReadMove( XNew, YNew );
    if ((X+XNew) <> X) OR ((Y+YNew) <> Y) then
      begin
        if ((X + XNew) > GetMaxX-1) then X := GetMaxX-1
          else if ((X + XNew) < 0) then X := 0
            else X := X + XNew;
        if ((Y + YNew) > GetMaxY-1) then Y := GetMaxY-1
          else if ((Y + YNew) < 0) then Y := 0
            else Y := Y + YNew;
        Show( False );
        for i := 0 to 3 do
          for j := 0 to 3 do
            ColOld[ i, j ] := GetPixel( X + i, Y + j );
        MPlot( X, Y );
        OldX := X; OldY := Y;
      end;
  end;


procedure GraphicMouse.Initialize;

   var mStatus : boolean;
       Btn : integer;

   begin
      Reset( mStatus, Btn );
      if mStatus then
        begin
          X := GetMaxX div 2;
          Y := GetMaxY div 2;
          OldX := X; OldY := Y;
          SetLimits( 0, 0, GetMaxX, GetMaxY );
          SetPosition( X, Y );
          MP[0,0] := 255; MP[0,1] := 255;  {     0 1 2 3  }
          MP[0,2] := 255; MP[0,3] := 255;  {  0  # # # #  }
          MP[1,0] := 255; MP[1,1] := 1;    {  1  # * * #  }
          MP[1,2] := 1;   MP[1,3] := 255;  {  2  # *      }
          MP[2,0] := 255; MP[2,1] := 1;    {  3  # #      }
          MP[2,2] := 0;   MP[2,3] := 0;    { Mouse Pointer }
          MP[3,0] := 255; MP[3,1] := 255;
          MP[3,2] := 0;   MP[3,3] := 0;
          Show( True );                    { Transparent = 0 }
        end;                               { White = 255     }
   end;                                    { Black = 1       }

procedure GraphicMouse.ExitSVGA;
   begin
      SetLimits( lo(WindMin)*8, hi(WindMin)*8, lo(WindMax)*8, hi(WindMax)*8);
      regs.AX := $0A;
      regs.BX := 1;
      regs.CX := 6;
      regs.DX := 7;
      intr($33,regs);
      SetPosition( 0, 0 );
      regs.AX := $02;
      intr($33,regs);
   end;

begin
  SetFont( StandardFont );
  SetFontColor( 253, 0, True );
  PresentSeg := 0;
  Sused := False;
  Fused := False;
end.