{$A+,B-,D+,E-,F+,G+,I-,L+,N+,O-,P-,Q-,R-,S-,T-,V-,X-}
{$M 65520,0,655360}
unit VGAGraph;
{втрое быстрее модуля GRAPH. Copyright (c) Bereznyak Taras}
interface

uses
  VGACtrls;

var
  GetMaxX, GetMaxY: word;

const
  VGA_640X200 = $0E;
  VGA_640X350 = $10;
  VGA_640X480 = $12;
  RPal: array [0 .. 15] of byte =
    ( 0,  0,  0,  0, 42, 42, 42, 42, 21, 21, 21, 21, 63, 63, 63, 63);
  GPal: array [0 .. 15] of byte =
    ( 0,  0, 42, 42,  0,  0, 21, 42, 21, 21, 63, 63, 21, 21, 63, 63);
  BPal: array [0 .. 15] of byte =
    ( 0, 42,  0, 42,  0, 42,  0, 42, 21, 63, 21, 63, 21, 63, 21, 63);
  EGANum: array [0 .. 15] of byte =
    (0, 1, 2, 3, 4, 5, 20, 7, 56, 57, 58, 59, 60, 61, 62, 63);

procedure InitGraph(Mode: byte);
procedure Restore;
procedure CloseGraph;
procedure SetRGB(Number: byte; R, G, B: byte);
procedure ClearBuffer;
procedure OutBuffer(Count: word);
procedure QuickOutBuffer;

procedure ReadCharTable(FileName: string);
procedure WriteCharTable(FileName: string);

procedure NormWin;
procedure RectToWin(var Rect: TRect);
procedure WinPutPixel(X, Y: integer; Color: byte);
procedure PutPixel(X, Y: integer; Color: byte);
function GetPixel(X, Y: integer): byte;
procedure FillPixel(X, Y: integer; Mask, Color: byte);
procedure FillOfsPixel(X, Y: integer; Mask, Color: byte);
procedure VertLine(X, Y1, Y2: integer; Color: byte);
procedure TexturedVertLine(X, Y1, Y2, Count: integer; var Texture);
procedure VertXorLine(X, Y1, Y2: integer; Color: byte);
procedure HorLine(X1, X2, Y: integer; Color: byte);
procedure FillVert(X, Y1, Y2: integer; Color: byte);
procedure Line(X1, Y1, X2, Y2: integer; Color: byte);
procedure ExLine(X1, Y1, X2, Y2: extended; Color: byte);
procedure Rectangle(X1, Y1, X2, Y2: integer; Color: byte);{
procedure ShadowRectangle(X1, Y1, X2, Y2: integer);
procedure FastRectangle(X1, Y1, X2, Y2: integer; Color: byte);  }
procedure Bar(X1, Y1, X2, Y2: integer; Color: byte);       {
procedure FastBar(X1, Y1, X2, Y2: integer; Color: byte);   }
procedure Circle(X, Y, R: integer; Color: byte);
procedure FillCircle(X, Y, R: integer; Color: byte);
procedure Ellipse(X, Y, Rx, Ry: integer; Color: byte);
procedure OrPixel(X, Y: integer; Plane: byte);
procedure XorPixel(X, Y: integer; Color: byte);
procedure FillTextXY(X, Y: integer; Text: string; Color: byte);
procedure OutTextXY(X, Y: integer; Text: string; Color: byte);
procedure DownTextXY(X, Y: integer; Text: string; Color: byte);
procedure MidTextXY(X, Y: integer; Text: string; Color: byte);
procedure COutTextXY(X, Y: integer; Text: string; Color: byte);
procedure CMidTextXY(X, Y: integer; Text: string; Color: byte);

function TextWidth(S: string): integer;
function TextHeight(S: string): integer;

procedure GetBuf(X, Y: integer);
procedure PutBuf(X, Y: integer);
procedure GetBuf2(X, Y: integer);
procedure PutBuf2(X, Y: integer);
procedure GetMouse;
procedure PutMouse(X, Y: integer);
procedure SetMouseColor(Color: byte);
function GetMouseColor: byte;
procedure ReadMouse(FileName: string);
function BufferToBmp256(FileName: string): boolean;

type
  TCharTable = array [char, 0 .. 7] of byte;
  PCharTable = ^TCharTable;
  TLayer = array [0 .. 38399] of byte;
  PLayer = ^TLayer;
  TScreenBuffer = array [0 .. 3] of PLayer;

const
  CharsSize = $800;

var
  {--это использовать лишь при крайней необходимости и понимании дела!!!!--}
  StartMode: byte;
  MaxX, MaxY, MemX: word;
  Buffer: TScreenBuffer;
  BaseBuf: word absolute Buffer;
  VideoSize: word;
  Chars: PCharTable;
  Buf, Buf2: array [0 .. 255] of byte;
  OrMouse, AndMouse: array [0 .. 31] of byte;
  GraphMode: byte;
  {---------------------------А это можно всегда---------------------------}
  Italic: boolean;
  WinMinX, WinMinY, WinMaxX, WinMaxY: integer;

const
  MouseColors: array [0 .. 3] of boolean =
    (True, True, True, False);

implementation

procedure InitGraph;
var
  i: integer;
begin
  case Mode of
    $0E: VideoSize := 80 * 200;
    $10: VideoSize := 80 * 350;
    $12: VideoSize := 80 * 480;
  end;
  if MaxAvail < 4 * LongInt(VideoSize)
     + LongInt(CharsSize) then begin
    WriteLn('Не хватает памяти. Осталось всего ', MaxAvail, ' байт.');
    WriteLn('Всего для инициализации надо ',
      4 * LongInt(VideoSize) + LongInt(CharsSize), ' байт.');
    Halt(203);
  end;
  asm
    mov ah, $0F
    int $10
    mov [startmode], al
    mov ah, $00
    mov al, [mode]
    mov [graphmode], al
    int $10
    mov [maxx], 639
    mov [getmaxx], 639
    mov [memx], 79
    cmp mode, $10
    ja @hig
    je @mid
    jb @low
    @hig:
      mov [maxy], 479
      mov [getmaxy], 479
      jmp @exit
    @mid:
      mov [maxy], 349
      mov [getmaxy], 349
      jmp @exit
    @low:
      mov [maxy], 199
      mov [getmaxy], 199
      jmp @exit
    @exit:
  end;
  WinMinX := 0;
  WinMinY := 0;
  WinMaxX := MaxX;
  WinMaxY := MaxY;
  for i := 0 to 3 do
    GetMem(Buffer[i], VideoSize);
  GetMem(Chars, CharsSize);
  ReadCharTable('stand8x8.fnt');
  ReadMouse('');
end;

procedure Restore; assembler;
asm
  mov ah, $00
  mov al, [graphmode]
  int $10
end;

procedure CloseGraph;
var
  i: integer;
begin
  asm
    mov ah, 0
    mov al, [startmode]
    mov [graphmode], al
    int $10
  end;
  for i := 0 to 3 do
    FreeMem(Buffer[i], VideoSize);
  FreeMem(Chars, CharsSize);
end;

procedure ReadCharTable;
var
  F: file of byte;
  i: char;
  j: integer;
begin
  j := IOResult;
  Assign(F, FileName);
  Reset(F);
  if IOResult = 0 then begin
    for i := #0 to #255 do
      for j := 0 to 7 do
        Read(F, Chars^[i, j]);
    Close(F);
  end;
end;

procedure WriteCharTable;
var
  F: file of byte;
  i: char;
  j: integer;
begin
  j := IOResult;
  Assign(F, FileName);
  Rewrite(F);
  if IOResult = 0 then begin
    for i := #0 to #255 do
      for j := 0 to 7 do
        Write(F, Chars^[i, j]);
    Close(F);
  end;
end;

procedure SetRGB;
var
  X: byte;
begin
  asm
    mov al, [number]
    mov dx, $03C8
    out dx, al
    mov dx, $03C9
    mov al, [r]
    out dx, al
    mov al, [g]
    out dx, al
    mov al, [b]
    out dx, al
  end;
  X := 0;
  case Number of
    20: X := 6;
    56 .. 63: X := Number - 48;
    else X := Number;
  end;
  RPal[X] := R;
  GPal[X] := G;
  BPal[X] := B;
end;

procedure ClearBuffer;
var
  i: integer;
begin
  for i := 0 to 3 do
    FillChar(Buffer[i]^, VideoSize, 0);
end;

procedure OutBuffer;
var
  i, j: integer;
  BlockSize, SegBlockSize, OfsBlockSize: word;
  SegBegCopy, OfsBegCopy: word;
  Adr: array [0 .. 7] of word absolute Buffer;
  Seg_, Ofs_: word;
  {$IFDEF MemTest}
  S: string;
  X1, Y1, X2, Y2: integer;
  {$ENDIF}
begin
  {$IFDEF MemTest}
  Str(MemAvail, S);
  X1 := 10;
  Y1 := 10;
  X2 := 74 + byte(S[0]) shl 3;
  Y2 := 18;
  Bar(X1 - 2, Y1 - 2, X2 + 2, Y2 + 2, 0);
  Rectangle(X1 - 3, Y1 - 3, X2 + 3, Y2 + 3, 15);
  OutTextXY(10, 10, 'Памяти: ' + S, 14);
  {$ENDIF}
  Port[$03C4] := 2;
  SegBegCopy := 0;
  OfsBegCopy := 0;
  BlockSize := VideoSize div Count;
  SegBlockSize := BlockSize shr 4;
  OfsBlockSize := BlockSize and $F;
  BlockSize := BlockSize shr 1;
  for i := 0 to Count - 1 do begin
    for j := 0 to 3 do begin
      Port[$03C5] := 1 shl j;
      Seg_ := Adr[j shl 1 or 1] + SegBegCopy;
      Ofs_ := Adr[j shl 1] + OfsBegCopy;
      asm
        push ds
        push si
        push es
        push di
        mov ax, $A000
        add ax, segbegcopy
        mov es, ax
        mov ax, 0
        add ax, ofsbegcopy
        mov di, ax
        mov cx, blocksize
        mov si, ofs_
        mov ds, seg_
        cld
        rep movsw
        pop di
        pop es
        pop si
        pop ds
      end;
    end;
    Inc(SegBegCopy, SegBlockSize);
    Inc(OfsBegCopy, OfsBlockSize);
  end;
end;

procedure QuickOutBuffer; assembler;
asm
  push si
  push es
  push di
  mov dx, $03C4
  mov ax, 2
  out dx, ax
  mov cx, 4
  @layer:
    push cx
    push ds
    dec cx
    mov dx, $03C5
    mov ax, 1
    shl ax, cl
    out dx, ax
    mov bx, cx
    shl bx, 2
    mov dx, [basebuf] + bx + 2
    mov si, [basebuf] + bx
    mov ax, $A000
    mov es, ax
    mov di, 0
    mov cx, videosize
    mov ds, dx
    shr cx, 1
    cld
    rep movsw
    pop ds
    pop cx
  loop @layer
  pop di
  pop es
  pop si
end;

procedure NormWin;
begin
  if WinMinX < 0 then
    WinMinX := 0;
  if WinMinY < 0 then
    WinMinY := 0;
  if WinMaxX > MaxX then
    WinMaxX := MaxX;
  if WinMaxY > MaxY then
    WinMaxY := MaxY;
end;

procedure RectToWin;
begin
  with Rect do begin
    WinMinX := X1;
    WinMinY := Y1;
    WinMaxX := X2;
    WinMaxY := Y2;
    NormWin;
  end;
end;

procedure PutPixel;
var
  Adress: word;
  Mask, NoMask: byte;
  i: integer;
begin
  if (X >= WinMinX) and (X <= WinMaxX)
  and (Y >= WinMinY) and (Y <= WinMaxY) then begin
    Adress := (X shr 3) + (Y shl 2 + Y) shl 4;
    Mask := 128 shr (X and 7);
    NoMask := not Mask;
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := Buffer[i]^[Adress] or Mask
      else
        Buffer[i]^[Adress] := Buffer[i]^[Adress] and NoMask;
  end;
end;

function GetPixel;
var
  Adress: word;
  i: integer;
  R: byte;
begin
  R := 0;
  if (X >= WinMinX) and (X <= WinMaxX)
  and (Y >= WinMinY) and (Y <= WinMaxY) then begin
    Adress := (X shr 3) + (Y shl 2 + Y) shl 4;
    for i := 0 to 3 do begin
      if Odd(Buffer[i]^[Adress] shr (X and 7 xor 7)) then
        R := R or (1 shl i);
    end;
  end;
  GetPixel := R;
end;

procedure WinPutPixel;
var
  Adress: word;
  Mask, NoMask: byte;
  i: integer;
begin
  if (X >= WinMinX) and (X <= WinMaxX)
  and (Y >= WinMinY) and (Y <= WinMaxY) then begin
    Adress := (X shr 3) + (Y shl 2 + Y) shl 4;
    Mask := 128 shr (X and 7);
    NoMask := not Mask;
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := Buffer[i]^[Adress] or Mask
      else
        Buffer[i]^[Adress] := Buffer[i]^[Adress] and NoMask;
  end;
end;

procedure XorPixel;
var
  Adress: word;
  Mask, NoMask: byte;
  i: integer;
begin
  if (X >= WinMinX) and (X <= WinMaxX)
  and (Y >= WinMinY) and (Y <= WinMaxY) then begin
    Adress := (X shr 3) + (Y shl 2 + Y) shl 4;
    Mask := 128 shr (X and 7);
    NoMask := not Mask;
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := Buffer[i]^[Adress] xor Mask;
  end;
end;

procedure FillPixel;
var
  Adress: word;
  i: integer;
begin
  if (X >= 0) and (X <= MemX) and (Y >= 0) and (Y <= MaxY) then begin
    Adress := X + (Y shl 2 + Y) shl 4;
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := Buffer[i]^[Adress] or Mask
      else
        Buffer[i]^[Adress] := Buffer[i]^[Adress] and not Mask;
  end;
end;

procedure FillOfsPixel;
var
  Adress: word;
  i: integer;
  Ofs, _Ofs: byte;
begin
  Ofs := X and 7;
  X := X shr 3;
  _Ofs := 8 - Ofs;
  if (X >= 0) and (X <= MemX) and (Y >= 0) and (Y <= MaxY) then begin
    Adress := X + (Y shl 2 + Y) shl 4;
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := Buffer[i]^[Adress] or (Mask shr Ofs)
      else
        Buffer[i]^[Adress] := Buffer[i]^[Adress] and not (Mask shr Ofs);
    Inc(Adress);
    if X < MemX then
      for i := 0 to 3 do
        if Odd(Color shr i) then
          Buffer[i]^[Adress] := Buffer[i]^[Adress] or (Mask shl _Ofs)
        else
          Buffer[i]^[Adress] := Buffer[i]^[Adress] and not (Mask shl _Ofs);
  end;
end;

procedure VertLine;
var
  Adress: word;
  Mask, NoMask: byte;
  i, j: word;
begin
  if (X < 0) or (X > MaxX) then
    Exit;
  if Y1 > Y2 then asm
    mov ax, [y2]
    mov bx, [y1]
    mov [y1], ax
    mov [y2], bx
  end;
  if (Y1 > MaxY) or (Y2 < 0) then
    Exit;
  if Y1 < 0 then
    Y1 := 0;
  if Y2 > MaxY then
    Y2 := MaxY;
  Adress := (X shr 3) + (Y1 shl 2 + Y1) shl 4;
  Mask := 128 shr (X and 7);
  NoMask := not Mask;
  for j := Y1 to Y2 do begin
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := Buffer[i]^[Adress] or Mask
      else
        Buffer[i]^[Adress] := Buffer[i]^[Adress] and NoMask;
    Inc(Adress, 80);
  end;
end;

procedure TexturedVertLine;
var
  Adress: word;
  Texture_: array [0 .. 65534] of byte absolute Texture;
  Mask, NoMask: byte;
  Index, DIndex: double;
  i, j: word;
  Color: byte;
begin
  if (X < 0) or (X > MaxX) then
    Exit;
  if Y1 > Y2 then asm
    mov ax, [y2]
    mov bx, [y1]
    mov [y1], ax
    mov [y2], bx
  end;
  if (Y1 > MaxY) or (Y2 < 0) then
    Exit;
  if Y1 < 0 then
    Y1 := 0;
  if Y2 > MaxY then
    Y2 := MaxY;
  Adress := (X shr 3) + (Y1 shl 2 + Y1) shl 4;
  Mask := 128 shr (X and 7);
  NoMask := not Mask;
  DIndex := Count / (Y2 - Y1 + 1);
  Index := 0;
  for j := Y1 to Y2 do begin
    Color := Texture_[Trunc(Index)];
    Index := Index + DIndex;
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := Buffer[i]^[Adress] or Mask
      else
        Buffer[i]^[Adress] := Buffer[i]^[Adress] and NoMask;
    Inc(Adress, 80);
  end;
end;

procedure VertXorLine;
var
  Adress: word;
  Mask, NoMask: byte;
  i, j: word;
begin
  if (X < 0) or (X > MaxX) then
    Exit;
  if Y1 > Y2 then asm
    mov ax, [y2]
    mov bx, [y1]
    mov [y1], ax
    mov [y2], bx
  end;
  if (Y1 > MaxY) or (Y2 < 0) then
    Exit;
  if Y1 < 0 then
    Y1 := 0;
  if Y2 > MaxY then
    Y2 := MaxY;
  Adress := (X shr 3) + (Y1 shl 2 + Y1) shl 4;
  Mask := 128 shr (X and 7);
  NoMask := not Mask;
  for j := Y1 to Y2 do begin
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := Buffer[i]^[Adress] xor Mask;
    Inc(Adress, 80);
  end;
end;

procedure HorLine;
var
  Adr1, Adr2: longint;
  Ofs1, Ofs2: byte;
  i, j: longint;
  Mask: byte;
begin
  if (Y < 0) or (Y > MaxY) then
    Exit;
  if X1 > X2 then asm
    mov ax, [x2]
    mov bx, [x1]
    mov [x1], ax
    mov [x2], bx
  end;
  if (X1 > MaxX) or (X2 < 0) then
    Exit;
  if X1 < 0 then
    X1 := 0;
  if X2 > MaxX then
    X2 := MaxX;
  Adr1 := (X1 shr 3) + (longint(Y) shl 6) + (longint(Y) shl 4);
  Adr2 := (X2 shr 3) + (longint(Y) shl 6) + (longint(Y) shl 4);
  Ofs1 := X1 and 7;
  Ofs2 := X2 and 7;
  for i := Adr1 + 1 to Adr2 - 1 do begin
    for j := 0 to 3 do
      if Odd(Color shr j) then
        Buffer[j]^[i] := 255
      else
        Buffer[j]^[i] := 0;
  end;
  if Adr1 = Adr2 then begin
    Mask := (255 shr Ofs1) xor (255 shr (Ofs2 + 1));
    for j := 0 to 3 do begin
      if Odd(Color shr j) then
        Buffer[j]^[Adr1] := Buffer[j]^[Adr1] or Mask
      else
        Buffer[j]^[Adr1] := Buffer[j]^[Adr1] and not Mask;
    end;
  end else begin
    Mask := 255 shr Ofs1;
    for j := 0 to 3 do begin
      if Odd(Color shr j) then
        Buffer[j]^[Adr1] := Buffer[j]^[Adr1] or Mask
      else
        Buffer[j]^[Adr1] := Buffer[j]^[Adr1] and not Mask;
    end;
    Mask := 255 shl (7 - Ofs2);
    for j := 0 to 3 do begin
      if Odd(Color shr j) then
        Buffer[j]^[Adr2] := Buffer[j]^[Adr2] or Mask
      else
        Buffer[j]^[Adr2] := Buffer[j]^[Adr2] and not Mask;
    end;
  end;
end;

procedure FillVert;
var
  Adress: word;
  i, j: word;
begin
  if (X < 0) or (X > MemX) then
    Exit;
  if Y1 > Y2 then asm
    mov ax, [y2]
    mov bx, [y1]
    mov [y1], ax
    mov [y2], bx
  end;
  if (Y1 > MaxY) or (Y2 < 0) then
    Exit;
  if Y1 < 0 then
    Y1 := 0;
  if Y2 > MaxY then
    Y2 := MaxY;
  Adress := X + (Y1 shl 2 + Y1) shl 4;
  for j := Y1 to Y2 do begin
    for i := 0 to 3 do
      if Odd(Color shr i) then
        Buffer[i]^[Adress] := 255
      else
        Buffer[i]^[Adress] := 0;
    Inc(Adress, 80);
  end;
end;

procedure Line;
var
  D: integer;
  X, Y, DX, DY, NX, NY: integer;
  IncR1, IncR2, XEnd, YEnd: integer;
begin
  XEnd := X1;
  YEnd := Y1;
  DX := Abs(Integer(X2) - Integer(X1));
  DY := Abs(Integer(Y2) - Integer(Y1));
  if DX > DY then begin
    D := DY shl 1 - DX;
    IncR1 := DY shl 1;
    IncR2 := (DY - DX) shl 1;
    XEnd := X2;
  end else begin
    D := DX shl 1 - DY;
    IncR1 := DX shl 1;
    IncR2 := (DX - DY) shl 1;
    YEnd := Y2;
  end;
  if X1 > X2 then
    NX := -1
  else
    NX := 1;
  if Y1 > Y2 then
    NY := -1
  else
    NY := 1;
  X := X1;
  Y := Y1;
  WinPutPixel(X, Y, Color);
  if DY < DX then
    while X <> XEnd do begin
      X := X + NX;
      if D < 0 then
        D := D + IncR1
      else begin
        Y := Y + NY;
        D := D + IncR2;
      end;
      WinPutPixel(X, Y, Color);
    end
  else
    while Y <> YEnd do begin
      Y := Y + NY;
      if D < 0 then
        D := D + IncR1
      else begin
        X := X + NX;
        D := D + IncR2;
      end;
      WinPutPixel(X, Y, Color);
    end;
end;

procedure ExLine;
var
  Dx, Dy: extended;
  e, de: extended;
  i: integer;
begin
  Dx := Abs(X1 - X2);
  Dy := Abs(Y1 - Y2);
  if (Dx = 0) and (Dy = 0) then begin
    WinPutPixel(Round(X1), Round(Y1), Color);
  end else if Dx > Dy then begin
    if X1 > X2 then begin
      e := X1;
      X1 := X2;
      X2 := e;
      e := Y1;
      Y1 := Y2;
      Y2 := e;
    end;
    e := Y1;
    de := (Y2 - Y1) / Dx;
    for i := Round(X1) to Round(X2) do begin
      WinPutPixel(i, Round(e), Color);
      e := e + de;
    end;
  end else begin
    if Y1 > Y2 then begin
      e := X1;
      X1 := X2;
      X2 := e;
      e := Y1;
      Y1 := Y2;
      Y2 := e;
    end;
    e := X1;
    de := (X2 - X1) / Dy;
    for i := Round(Y1) to Round(Y2) do begin
      WinPutPixel(Round(e), i, Color);
      e := e + de;
    end;
  end;
end;
               {
procedure Rectangle;
begin
  if X1 > X2 then asm
    mov ax, [x1]
    mov bx, [x2]
    mov [x1], bx
    mov [x2], ax
  end;
  if Y1 > Y2 then asm
    mov ax, [y1]
    mov bx, [y2]
    mov [y1], bx
    mov [y2], ax
  end;
  HorLine(X1 + 3, X2 - 3, Y1, Color);
  HorLine(X1 + 1, X1 + 3, Y1 + 1, Color);
  HorLine(X2 - 3, X2 - 1, Y1 + 1, Color);
  HorLine(X1 + 3, X2 - 3, Y2, Color);
  HorLine(X1 + 1, X1 + 3, Y2 - 1, Color);
  HorLine(X2 - 3, X2 - 1, Y2 - 1, Color);
  VertLine(X1, Y1 + 3, Y2 - 3, Color);
  VertLine(X1 + 1, Y2 - 3, Y2 - 1, Color);
  VertLine(X1 + 1, Y1 + 1, Y1 + 3, Color);
  VertLine(X2, Y1 + 3, Y2 - 3, Color);
  VertLine(X2 - 1, Y2 - 3, Y2 - 1, Color);
  VertLine(X2 - 1, Y1 + 1, Y1 + 3, Color);
end;    }

procedure {Fast}Rectangle;
begin
  HorLine(X1, X2, Y1, Color);
  HorLine(X1, X2, Y2, Color);
  VertLine(X1, Y1, Y2, Color);
  VertLine(X2, Y1, Y2, Color);
end;

procedure {Fast}Bar;
var
  i, j, k: longint;
  Adr1, Adr2: longint;
  Adress: word;
  Mask: byte;
  Ofs1, Ofs2: byte;
begin
  if X1 > X2 then asm
    mov ax, [x2]
    mov bx, [x1]
    mov [x1], ax
    mov [x2], bx
  end;
  if (X1 > MaxX) or (X2 < 0) then
    Exit;
  if X1 < 0 then
    X1 := 0;
  if X2 > MaxX then
    X2 := MaxX;
  if Y1 > Y2 then asm
    mov ax, [y1]
    mov bx, [y2]
    mov [y1], bx
    mov [y2], ax
  end;
  if (Y1 > MaxY) or (Y2 < 0) then
    Exit;
  if Y1 < 0 then
    Y1 := 0;
  if Y2 > MaxY then
    Y2 := MaxY;
  Adr1 := (X1 shr 3) + (Y1 shl 6) + (Y1 shl 4);
  Adr2 := (X2 shr 3) + (Y1 shl 6) + (Y1 shl 4);
  Ofs1 := X1 and 7;
  Ofs2 := X2 and 7;
  for k := Y1 to Y2 do begin
    for i := Adr1 + 1 to Adr2 - 1 do begin
      for j := 0 to 3 do begin
        if Odd(Color shr j) then
          Buffer[j]^[i] := 255
        else
          Buffer[j]^[i] := 0;
      end;
    end;
    if Adr1 = Adr2 then begin
      Mask := (255 shr Ofs1) xor (255 shr (Ofs2 + 1));
      for j := 0 to 3 do begin
        if Odd(Color shr j) then
          Buffer[j]^[Adr1] := Buffer[j]^[Adr1] or Mask
        else
          Buffer[j]^[Adr1] := Buffer[j]^[Adr1] and not Mask;
      end;
    end else begin
      Mask := 255 shr Ofs1;
      for j := 0 to 3 do begin
        if Odd(Color shr j) then
          Buffer[j]^[Adr1] := Buffer[j]^[Adr1] or Mask
        else
          Buffer[j]^[Adr1] := Buffer[j]^[Adr1] and not Mask;
      end;
      Mask := 255 shl (7 - Ofs2);
      for j := 0 to 3 do begin
        if Odd(Color shr j) then
          Buffer[j]^[Adr2] := Buffer[j]^[Adr2] or Mask
        else
          Buffer[j]^[Adr2] := Buffer[j]^[Adr2] and not Mask;
      end;
    end;
    Inc(Adr1, 80);
    Inc(Adr2, 80);
  end;
end;
           {
procedure Bar;
begin
  if X1 > X2 then asm
    mov ax, [x2]
    mov bx, [x1]
    mov [x1], ax
    mov [x2], bx
  end;
  if Y1 > Y2 then asm
    mov ax, [y1]
    mov bx, [y2]
    mov [y1], bx
    mov [y2], ax
  end;
  FastBar(X1 + 1, Y1 + 1, X2 - 1, Y2 - 1, Color);
  HorLine(X1 + 3, X2 - 3, Y1, Color);
  HorLine(X1 + 3, X2 - 3, Y2, Color);
  VertLine(X1, Y1 + 3, Y2 - 3, Color);
  VertLine(X2, Y1 + 3, Y2 - 3, Color);
end;   }

procedure Circle;
var
  Dx, Dy, D:integer;
begin
  Dx := 0;
  Dy := R;
  D := 3 - Dy shl 1;
  while Dx <= Dy do begin
    WinPutPixel(Dx + X, Dy + Y, Color);
    WinPutPixel(-Dx + X, Dy + Y, Color);
    WinPutPixel(Dx + X, -Dy + Y, Color);
    WinPutPixel(-Dx + X, -Dy + Y, Color);
    WinPutPixel(Dy + X, Dx + Y, Color);
    WinPutPixel(-Dy + X, Dx + Y, Color);
    WinPutPixel(Dy + X, -Dx + Y, Color);
    WinPutPixel(-Dy + X, -Dx + Y, Color);
    if D < 0 then
      D := D + Dx shl 2 + 6
    else begin
      D := D + (Dx - Dy) shl 2 + 10;
      Dec(Dy);
    end;
    Inc(Dx);
  end;
end;

procedure FillCircle;
var
  Dx, Dy, D:integer;
begin
  Dx := 0;
  Dy := R;
  D := 3 - Dy shl 1;
  while Dx <= Dy do begin
    if Abs(Dy) < R then begin
      HorLine(X - Dx + 1, X + Dx - 1, Y + Dy, Color);
      HorLine(X - Dx + 1, X + Dx - 1, Y - Dy, Color);
    end;
    HorLine(X - Dy + 1, X + Dy - 1, Y + Dx, Color);
    HorLine(X - Dy + 1, X + Dy - 1, Y - Dx, Color);
    if D < 0 then
      D := D + Dx shl 2 + 6
    else begin
      D := D + (Dx - Dy) shl 2 + 10;
      Dec(Dy);
    end;
    Inc(Dx);
  end;
end;

procedure Ellipse;
var
  Dx, Dy, D, RDx, RDy: integer;
  Diff: extended;
begin
  if (Rx = 0) and (Ry = 0) then
  else if (Rx < 0) or (Ry < 0) then
  else if Ry < Rx then begin
    Dx := 0;
    Dy := Rx;
    D := 3 - Dy shl 1;
    Diff := Ry / Rx;
    while Dx <= Dy do begin
      RDx := Round(Dx * Diff);
      RDy := Round(Dy * Diff);
      WinPutPixel(Dx + X, RDy + Y, Color);
      WinPutPixel(-Dx + X, RDy + Y, Color);
      WinPutPixel(Dx + X, -RDy + Y, Color);
      WinPutPixel(-Dx + X, -RDy + Y, Color);
      WinPutPixel(Dy + X, RDx + Y, Color);
      WinPutPixel(-Dy + X, RDx + Y, Color);
      WinPutPixel(Dy + X, -RDx + Y, Color);
      WinPutPixel(-Dy + X, -RDx + Y, Color);
      if D < 0 then
        D := D + Dx shl 2 + 6
      else begin
        D := D + (Dx - Dy) shl 2 + 10;
        Dec(Dy);
      end;
      Inc(Dx);
    end;
  end else begin
    Dy := 0;
    Dx := Ry;
    D := 3 - Dx shl 1;
    Diff := Rx / Ry;
    while Dy <= Dx do begin
      RDx := Round(Dx * Diff);
      RDy := Round(Dy * Diff);
      PutPixel(RDx + X, Dy + Y, Color);
      PutPixel(-RDx + X, Dy + Y, Color);
      PutPixel(RDx + X, -Dy + Y, Color);
      PutPixel(-RDx + X, -Dy + Y, Color);
      PutPixel(RDy + X, Dx + Y, Color);
      PutPixel(-RDy + X, Dx + Y, Color);
      PutPixel(RDy + X, -Dx + Y, Color);
      PutPixel(-RDy + X, -Dx + Y, Color);
      if D < 0 then
        D := D + Dy shl 2 + 6
      else begin
        D := D + (Dy - Dx) shl 2 + 10;
        Dec(Dx);
      end;
      Inc(Dy);
    end;
  end;
end;

procedure OrPixel;
var
  Adress: word;
  Mask: byte;
begin
  if (X >= 0) and (X <= MaxX) and (Y >= 0) and (Y <= MaxY)
  and (Plane < 4) then begin
    Adress := (X shr 3) + (Y shl 2 + Y) shl 4;
    Mask := 128 shr (X and 7);
    Buffer[Plane]^[Adress] := Buffer[Plane]^[Adress] or Mask
  end;
end;

procedure FillTextXY;
var
  i, j: integer;
begin
  X := X shr 3;
  for i := 1 to Byte(Text[0]) do
    for j := 0 to 7 do
      FillPixel(X + i - 1, Y + j, Chars^[Text[i], j], Color);
end;

procedure OutTextXY;
var
  i, j: integer;
  Index: integer;
  Col: byte;
  Ofs: byte;
  Norm: byte;
begin
  Index := 0;
  Norm := 17;
  Col := Color;
  for i := 1 to byte(Text[0]) do begin
    if Norm = 18 then begin
      Norm := byte(Text[i]);
    end else if (Text[i] = #0) and (Norm = 17) then begin
      Norm := 18;
    end else if (Text[i] <> #0) and (Norm < 18) then begin
      Norm := 17;
      Inc(Index);
      if Italic then
        for j := 0 to 7 do
          FillOfsPixel(X + ((Index - 1) shl 3) - (j shr 2) + 1,
            Y + j, Chars^[Text[i], j], Col)
      else
        for j := 0 to 7 do
          FillOfsPixel(X + ((Index - 1) shl 3),
            Y + j, Chars^[Text[i], j], Col);
    end;
  end;
end;

procedure DownTextXY;
var
  i, j, k: integer;
  C: byte;
begin
  for i := 1 to Byte(Text[0]) do
    for j := 0 to 7 do begin
      C := 0;
      for k := 0 to 7 do
        if Chars^[Text[i], k] shr (j xor 7) and 1 = 1 then
          C := C or (1 shl k);
      FillOfsPixel(X, Y + j + (i - 1) shl 3, C, Color);
    end;
end;

procedure MidTextXY;
var
  i, j: integer;
  Index: integer;
  Col: byte;
  Ofs: byte;
  Norm: byte;
  Len: byte;
begin
  Len := byte(Text[0]);
  Norm := 17;
  for i := 1 to byte(Text[0]) do begin
    if (Text[i] = #0) and (Norm = 17) then begin
      Norm := 18;
      Dec(Len);
    end else if Norm = 18 then begin
      Norm := 17;
      Dec(Len);
    end;
  end;
  X := X - Len shl 2;
  Index := 0;
  Norm := 17;
  Col := Color;
  for i := 1 to byte(Text[0]) do begin
    if Norm = 18 then begin
      Norm := byte(Text[i]);
    end else if (Text[i] = #0) and (Norm = 17) then begin
      Norm := 18;
    end else if (Text[i] <> #0) and (Norm < 18) then begin
      Norm := 17;
      Inc(Index);
      if Italic then
        for j := 0 to 7 do
          FillOfsPixel(X + ((Index - 1) shl 3) - (j shr 2) + 1,
            Y + j, Chars^[Text[i], j], Col)
      else
        for j := 0 to 7 do
          FillOfsPixel(X + ((Index - 1) shl 3),
            Y + j, Chars^[Text[i], j], Col);
    end;
  end;
end;

procedure COutTextXY;
var
  i, j: integer;
  Index: integer;
  Col: byte;
  Ofs: byte;
  Norm: byte;
begin
  Index := 0;
  Norm := 18;
  Col := Color;
  for i := 1 to byte(Text[0]) do begin
    if Norm = 19 then begin
      Norm := byte(Text[i]);
      if Norm = 17 then
        Norm := Color;
      Col := Norm;
    end else if (Text[i] = #0) and (Norm = 18) then begin
      Norm := 19;
    end else if (Text[i] <> #0) and (Norm < 19) then begin
      Norm := 18;
      Inc(Index);
      if Italic then
        for j := 0 to 7 do
          FillOfsPixel(X + ((Index - 1) shl 3) - (j shr 2) + 1,
            Y + j, Chars^[Text[i], j], Col)
      else
        for j := 0 to 7 do
          FillOfsPixel(X + ((Index - 1) shl 3),
            Y + j, Chars^[Text[i], j], Col);
    end;
  end;
end;

procedure CMidTextXY;
var
  i, j: integer;
  Index: integer;
  Col: byte;
  Ofs: byte;
  Norm: byte;
  Len: byte;
begin
  Len := byte(Text[0]);
  Norm := 18;
  for i := 1 to byte(Text[0]) do begin
    if (Text[i] = #0) and (Norm = 18) then begin
      Norm := 19;
      Dec(Len);
    end else if Norm = 19 then begin
      Norm := 18;
      Dec(Len);
    end;
  end;
  X := X - Len shl 2;
  Index := 0;
  Norm := 18;
  Col := Color;
  for i := 1 to byte(Text[0]) do begin
    if Norm = 19 then begin
      Norm := byte(Text[i]);
      if Norm = 17 then
        Norm := Color;
      Col := Norm;
    end else if (Text[i] = #0) and (Norm = 18) then begin
      Norm := 19;
    end else if (Text[i] <> #0) and (Norm < 19) then begin
      Norm := 18;
      Inc(Index);
      if Italic then
        for j := 0 to 7 do
          FillOfsPixel(X + ((Index - 1) shl 3) - (j shr 2) + 1,
            Y + j, Chars^[Text[i], j], Col)
      else
        for j := 0 to 7 do
          FillOfsPixel(X + ((Index - 1) shl 3),
            Y + j, Chars^[Text[i], j], Col);
    end;
  end;
end;

function TextWidth;
begin
  TextWidth := 8 * Ord(S[0]);
end;

function TextHeight;
begin
  TextHeight := 8;
end;

procedure GetBuf;
var
  Adress, Adr: word;
  i, j: integer;
begin
  Adr := (Y shl 6) + (Y shl 4) + (X shr 3);
  for j := 0 to 3 do begin
    Adress := Adr;
    for i := 0 to 15 do begin
      if (X < 640) and (Adress < VideoSize) then
        Buf[(j shl 6) or (i shl 2)] := Buffer[j]^[Adress];
      Inc(Adress);
      if (X < 632) and (Adress < VideoSize) then
        Buf[(j shl 6) or (i shl 2) or 1] := Buffer[j]^[Adress];
      Inc(Adress);
      if (X < 624) and (Adress < VideoSize) then
        Buf[(j shl 6) or (i shl 2) or 2] := Buffer[j]^[Adress];
      Inc(Adress);
      if (X < 616) and (Adress < VideoSize) then
        Buf[(j shl 6) or (i shl 2) or 3] := Buffer[j]^[Adress];
      Inc(Adress, 77);
    end;
  end;
end;

procedure PutBuf;
var
  Adress, Adr: word;
  i, j: integer;
begin
  Adr := (Y shl 6) + (Y shl 4) + (X shr 3);
  for j := 0 to 3 do begin
    Adress := Adr;
    for i := 0 to 15 do begin
      if (X < 640) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buf[(j shl 6) or (i shl 2)];
      Inc(Adress);
      if (X < 632) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buf[(j shl 6) or (i shl 2) or 1];
      Inc(Adress);
      if (X < 624) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buf[(j shl 6) or (i shl 2) or 2];
      Inc(Adress);
      if (X < 616) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buf[(j shl 6) or (i shl 2) or 3];
      Inc(Adress, 77);
    end;
  end;
end;

procedure GetBuf2;
var
  Adress, Adr: word;
  i, j: integer;
begin
  Adr := (Y shl 6) + (Y shl 4) + (X shr 3);
  for j := 0 to 3 do begin
    Adress := Adr;
    for i := 0 to 15 do begin
      if (X < 640) and (Adress < VideoSize) then
        Buf2[(j shl 6) or (i shl 2)] := Buffer[j]^[Adress];
      Inc(Adress);
      if (X < 632) and (Adress < VideoSize) then
        Buf2[(j shl 6) or (i shl 2) or 1] := Buffer[j]^[Adress];
      Inc(Adress);
      if (X < 624) and (Adress < VideoSize) then
        Buf2[(j shl 6) or (i shl 2) or 2] := Buffer[j]^[Adress];
      Inc(Adress);
      if (X < 616) and (Adress < VideoSize) then
        Buf2[(j shl 6) or (i shl 2) or 3] := Buffer[j]^[Adress];
      Inc(Adress, 77);
    end;
  end;
end;

procedure PutBuf2;
var
  Adress, Adr: word;
  i, j: integer;
begin
  Adr := (Y shl 6) + (Y shl 4) + (X shr 3);
  for j := 0 to 3 do begin
    Adress := Adr;
    for i := 0 to 15 do begin
      if (X < 640) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buf2[(j shl 6) or (i shl 2)];
      Inc(Adress);
      if (X < 632) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buf2[(j shl 6) or (i shl 2) or 1];
      Inc(Adress);
      if (X < 624) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buf2[(j shl 6) or (i shl 2) or 2];
      Inc(Adress);
      if (X < 616) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buf2[(j shl 6) or (i shl 2) or 3];
      Inc(Adress, 77);
    end;
  end;
end;

procedure GetMouse;
var
  Adress: word;
  i: integer;
begin
  Adress := 0;
  for i := 0 to 15 do begin
    OrMouse[i shl 1] := Buffer[0]^[Adress];
    OrMouse[i shl 1 or 1] := Buffer[0]^[Adress or 1];
    AndMouse[i shl 1] := Buffer[1]^[Adress];
    AndMouse[i shl 1 or 1] := Buffer[1]^[Adress or 1];
    Inc(Adress, 80);
  end;
end;

procedure PutMouse;
var
  Adress, Adr, Ofs, _Ofs: word;
  i, j: integer;
  BTime: byte absolute $0040: $006C;
  TmpOr1, TmpOr2: byte;
begin
  Ofs := X and 7;
  _Ofs := 8 - Ofs;
  Adr := (Y shl 6) + (Y shl 4) + (X shr 3);
  for j := 0 to 3 do begin
    Adress := Adr;
    for i := 0 to 15 do begin
      if (MouseColors[j]) or (i + BTime and 15 = 15) then begin
        TmpOr1 := OrMouse[i shl 1];
        TmpOr2 := OrMouse[i shl 1 or 1];
      end else begin
        TmpOr1 := 0;
        TmpOr2 := 0;
      end;
      if (X < 640) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buffer[j]^[Adress]
          and (not (AndMouse[i shl 1] shr Ofs))
          or (TmpOr1 shr Ofs);
      Inc(Adress);
      if (X < 632) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buffer[j]^[Adress]
          and (not (AndMouse[i shl 1 or 1] shr Ofs))
          and (not (AndMouse[i shl 1] shl _Ofs))
          or (tmpOr2 shr Ofs)
          or (tmpOr1 shl _Ofs);
      Inc(Adress);
      if (X < 624) and (Adress < VideoSize) then
        Buffer[j]^[Adress] := Buffer[j]^[Adress]
          and (not (AndMouse[i shl 1 or 1] shl _Ofs))
          or (tmpOr2 shl _Ofs);
      Inc(Adress, 78);
    end;
  end;
end;

procedure ReadMouse;
var
  F: file of byte;
  i: integer;
begin
  if FileName = '' then begin
    AndMouse[00] := $80;
    AndMouse[01] := $00;
    AndMouse[02] := $C0;
    AndMouse[03] := $00;
    AndMouse[04] := $F0;
    AndMouse[05] := $00;
    AndMouse[06] := $78;
    AndMouse[07] := $00;
    AndMouse[08] := $7E;
    AndMouse[09] := $00;
    AndMouse[10] := $3F;
    AndMouse[11] := $00;
    AndMouse[12] := $3B;
    AndMouse[13] := $C0;
    AndMouse[14] := $19;
    AndMouse[15] := $F0;
    AndMouse[16] := $1C;
    AndMouse[17] := $78;
    AndMouse[18] := $0C;
    AndMouse[19] := $1E;
    AndMouse[20] := $0E;
    AndMouse[21] := $7F;
    AndMouse[22] := $07;
    AndMouse[23] := $FC;
    AndMouse[24] := $07;
    AndMouse[25] := $C0;
    AndMouse[26] := $03;
    AndMouse[27] := $C0;
    AndMouse[28] := $03;
    AndMouse[29] := $80;
    AndMouse[30] := $01;
    AndMouse[31] := $80;
    OrMouse[00] := $80;
    OrMouse[01] := $00;
    OrMouse[02] := $40;
    OrMouse[03] := $00;
    OrMouse[04] := $70;
    OrMouse[05] := $00;
    OrMouse[06] := $38;
    OrMouse[07] := $00;
    OrMouse[08] := $3E;
    OrMouse[09] := $00;
    OrMouse[10] := $13;
    OrMouse[11] := $00;
    OrMouse[12] := $19;
    OrMouse[13] := $C0;
    OrMouse[14] := $08;
    OrMouse[15] := $70;
    OrMouse[16] := $0C;
    OrMouse[17] := $18;
    OrMouse[18] := $04;
    OrMouse[19] := $0E;
    OrMouse[20] := $06;
    OrMouse[21] := $3F;
    OrMouse[22] := $03;
    OrMouse[23] := $60;
    OrMouse[24] := $03;
    OrMouse[25] := $40;
    OrMouse[26] := $01;
    OrMouse[27] := $C0;
    OrMouse[28] := $01;
    OrMouse[29] := $80;
    OrMouse[30] := $00;
    OrMouse[31] := $80;
  end else begin
    Assign(F, FileName);
    Reset(F);
    if IOResult = 0 then begin
      for i := 0 to 31 do
        Read(F, AndMouse[i]);
      for i := 0 to 31 do
        Read(F, OrMouse[i]);
      Close(F);
    end;
  end;
end;

procedure SetMouseColor(Color: byte);
var
  i: integer;
begin
  for i := 0 to 3 do
    MouseColors[i] := Odd(Color shr i);
end;

function GetMouseColor: byte;
var
  i: integer;
  R: byte;
begin
  R := 0;
  for i := 0 to 3 do
    if MouseColors[i] then
      R := R or (1 shl i);
  GetMouseColor := R;
end;

function BufferToBmp256;
var
  F: file of byte;
  i, j: integer;
  B1, B2: byte;

procedure WriteB(B: byte);
begin
  Write(F, B);
end;

procedure WriteW(W: integer);
var
  B: array [0 .. 1] of byte absolute W;
begin
  Write(F, B[0]);
  Write(F, B[1]);
end;

procedure WriteL(L: longint);
var
  B: array [0 .. 3] of byte absolute L;
begin
  Write(F, B[0]);
  Write(F, B[1]);
  Write(F, B[2]);
  Write(F, B[3]);
end;

procedure Empty(Count: longint);
var
  i: longint;
  B: byte;
begin
  B := 0;
  for i := 0 to Count - 1 do
    Write(F, B);
end;

procedure Full(Count: longint);
var
  i: longint;
  B: byte;
begin
  B := 255;
  for i := 0 to Count - 1 do
    Write(F, B);
end;

begin
  i := IOResult;
  Assign(F, FileName);
  Rewrite(F);
  if IOResult = 0 then begin
    WriteB($42);
    WriteB($4D);
    WriteL(640 * 480 + $436);
    WriteL($00000000);
    WriteL($00000436);
    WriteL($00000028);
    WriteL(640);
    WriteL(480);
    WriteL($00080001);
    WriteL($00000000);
    WriteL($00000100);
    WriteL($00000EC4);
    WriteL($00000EC4);
    Empty(8);
    for i := 0 to 15 do begin
      WriteB(Round(BPal[i] * (255 / 63)));
      WriteB(Round(GPal[i] * (255 / 63)));
      WriteB(Round(RPal[i] * (255 / 63)));
      WriteB(0);
    end;
    for i := 16 to 255 do begin
      WriteB(0);
      WriteB(0);
      WriteB(0);
      WriteB(0);
    end;
    for j := 479 downto 0 do
      for i := 0 to 639 do begin
        B1 := GetPixel(i, j);
        WriteB(B1);
      end;
    Close(F);
    BufferToBmp256 := True;
  end else
    BufferToBmp256 := False;
end;

end.