Unit Graphics;
{----------------------------------------------------------------------------}
{ Graphics : An implementation of a graphics library. All standard VGA and }
{ VESA modes are supported. A Tseng Labs ET4000 specific }
{ implementation is also included. }
{****************************************************************************}
{ Author : Menno Victor van der star }
{ Developed on : 08-06-'95 }
{ Last update on : 07-09-'95 }
{ Status : All modes are operational but some of the less }
{ frequently used ones are extremely slow because they }
{ use BIOS calls instead of mode-specific code. }
{ The NOT, AND, OR and XOR modes are not yet supported. }
{ Due to GPF-faults, Vesa is defined for, and can }
{ subsequently only be used in Real mode. }
{ Future extensions : - X-MODE specific implementation }
{ - Support for fillpattern in BoundaryFill/FloodFill }
{ - Support for linestyles }
{ - Support for write-modes other than NORMAL }
{ - More graphic functions like : }
{ * Convex Hull }
{ * Etcetera... }
{ - Implementations for other chip-sets }
{----------------------------------------------------------------------------}
{$N+,E+,R-}
Interface
Uses Dos;
Type
GraphicsMode = Record
Mode, { Number to pass to BIOS to initialize video mode, if necessary }
Width, Height : Word; { Width and Height of video mode }
ColorDepth : Byte; { Colordepth in bits per pixel }
End;
RGB = Record r, g, b : Byte; End;
Point = Record x, y : Integer; End;
Triangle = Array [1..3] Of Point;
ByteArray = Array [0..0] Of Byte;
PByteArray = ^ByteArray;
Const
{ Standard VGA modes }
VGA320x200x4 : GraphicsMode = (Mode : $04; Width : 320; Height : 200; ColorDepth : 2);
VGA640x200x2 : GraphicsMode = (Mode : $06; Width : 640; Height : 200; ColorDepth : 1);
VGA320x200x16 : GraphicsMode = (Mode : $0D; Width : 320; Height : 200; ColorDepth : 4);
VGA640x200x16 : GraphicsMode = (Mode : $0E; Width : 640; Height : 200; ColorDepth : 4);
VGA640x350x4 : GraphicsMode = (Mode : $0F; Width : 640; Height : 350; ColorDepth : 2);
VGA640x350x16 : GraphicsMode = (Mode : $10; Width : 640; Height : 350; ColorDepth : 4);
VGA640x480x2 : GraphicsMode = (Mode : $11; Width : 640; Height : 480; ColorDepth : 1);
VGA640x480x16 : GraphicsMode = (Mode : $12; Width : 640; Height : 480; ColorDepth : 4);
VGA320x200x256 : GraphicsMode = (Mode : $13; Width : 320; Height : 200; ColorDepth : 8);
{$IFNDEF DPMI}
{ Standard VESA modes, Vesa calls currently only possible in real mode :( }
Vesa640x400x256 : GraphicsMode = (Mode : $100; Width : 640; Height : 400; ColorDepth : 8);
Vesa640x480x256 : GraphicsMode = (Mode : $101; Width : 640; Height : 480; ColorDepth : 8);
Vesa800x600x16 : GraphicsMode = (Mode : $102; Width : 800; Height : 600; ColorDepth : 4);
Vesa800x600x256 : GraphicsMode = (Mode : $103; Width : 800; Height : 600; ColorDepth : 8);
Vesa1024x768x16 : GraphicsMode = (Mode : $104; Width : 1024; Height : 768; ColorDepth : 4);
Vesa1024x768x256 : GraphicsMode = (Mode : $105; Width : 1024; Height : 768; ColorDepth : 8);
Vesa1280x1024x16 : GraphicsMode = (Mode : $106; Width : 1280; Height : 1024; ColorDepth : 4);
Vesa1280x1024x256 : GraphicsMode = (Mode : $107; Width : 1280; Height : 1024; ColorDepth : 8);
{$ENDIF}
{ Card-specific video modes for Tseng Labs ET4000 chipset }
Tseng640x480x256 : GraphicsMode = (Mode : $2E; Width : 640; Height : 480; ColorDepth : 8);
Tseng800x600x16 : GraphicsMode = (Mode : $29; Width : 800; Height : 600; ColorDepth : 4);
Tseng800x600x256 : GraphicsMode = (Mode : $30; Width : 800; Height : 600; ColorDepth : 8);
Tseng1024x768x16 : GraphicsMode = (Mode : $37; Width : 1024; Height : 768; ColorDepth : 4);
Tseng1024x768x256 : GraphicsMode = (Mode : $38; Width : 1024; Height : 768; ColorDepth : 8);
Tseng1280x1024x16 : GraphicsMode = (Mode : $3D; Width : 1280; Height : 1024; ColorDepth : 4);
{ Default rom font }
DefaultFont : Array [0..2047] Of Byte =
( 0, 0, 0, 0, 0, 0, 0, 0,126,129,165,129,189,153,129,126,
126,255,219,255,195,231,255,126,108,254,254,254,124, 56, 16, 0,
16, 56,124,254,124, 56, 16, 0, 56,124, 56,254,254,124, 56,124,
16, 16, 56,124,254,124, 56,124, 0, 0, 24, 60, 60, 24, 0, 0,
255,255,231,195,195,231,255,255, 0, 60,102, 66, 66,102, 60, 0,
255,195,153,189,189,153,195,255, 15, 7, 15,125,204,204,204,120,
60,102,102,102, 60, 24,126, 24, 63, 51, 63, 48, 48,112,240,224,
127, 99,127, 99, 99,103,230,192,153, 90, 60,231,231, 60, 90,153,
128,224,248,254,248,224,128, 0, 2, 14, 62,254, 62, 14, 2, 0,
24, 60,126, 24, 24,126, 60, 24,102,102,102,102,102, 0,102, 0,
127,219,219,123, 27, 27, 27, 0, 62, 99, 56,108,108, 56,204,120,
0, 0, 0, 0,126,126,126, 0, 24, 60,126, 24,126, 60, 24,255,
24, 60,126, 24, 24, 24, 24, 0, 24, 24, 24, 24,126, 60, 24, 0,
0, 24, 12,254, 12, 24, 0, 0, 0, 48, 96,254, 96, 48, 0, 0,
0, 0,192,192,192,254, 0, 0, 0, 36,102,255,102, 36, 0, 0,
0, 24, 60,126,255,255, 0, 0, 0,255,255,126, 60, 24, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 48,120,120, 48, 48, 0, 48, 0,
108,108,108, 0, 0, 0, 0, 0,108,108,254,108,254,108,108, 0,
48,124,192,120, 12,248, 48, 0, 0,198,204, 24, 48,102,198, 0,
56,108, 56,118,220,204,118, 0, 96, 96,192, 0, 0, 0, 0, 0,
24, 48, 96, 96, 96, 48, 24, 0, 96, 48, 24, 24, 24, 48, 96, 0,
0,102, 60,255, 60,102, 0, 0, 0, 48, 48,252, 48, 48, 0, 0,
0, 0, 0, 0, 0, 48, 48, 96, 0, 0, 0,252, 0, 0, 0, 0,
0, 0, 0, 0, 0, 48, 48, 0, 6, 12, 24, 48, 96,192,128, 0,
124,198,206,222,246,230,124, 0, 48,112, 48, 48, 48, 48,252, 0,
120,204, 12, 56, 96,204,252, 0,120,204, 12, 56, 12,204,120, 0,
28, 60,108,204,254, 12, 30, 0,252,192,248, 12, 12,204,120, 0,
56, 96,192,248,204,204,120, 0,252,204, 12, 24, 48, 48, 48, 0,
120,204,204,120,204,204,120, 0,120,204,204,124, 12, 24,112, 0,
0, 48, 48, 0, 0, 48, 48, 0, 0, 48, 48, 0, 0, 48, 48, 96,
24, 48, 96,192, 96, 48, 24, 0, 0, 0,252, 0, 0,252, 0, 0,
96, 48, 24, 12, 24, 48, 96, 0,120,204, 12, 24, 48, 0, 48, 0,
124,198,222,222,222,192,120, 0, 48,120,204,204,252,204,204, 0,
252,102,102,124,102,102,252, 0, 60,102,192,192,192,102, 60, 0,
248,108,102,102,102,108,248, 0,254, 98,104,120,104, 98,254, 0,
254, 98,104,120,104, 96,240, 0, 60,102,192,192,206,102, 62, 0,
204,204,204,252,204,204,204, 0,120, 48, 48, 48, 48, 48,120, 0,
30, 12, 12, 12,204,204,120, 0,230,102,108,120,108,102,230, 0,
240, 96, 96, 96, 98,102,254, 0,198,238,254,254,214,198,198, 0,
198,230,246,222,206,198,198, 0, 56,108,198,198,198,108, 56, 0,
252,102,102,124, 96, 96,240, 0,120,204,204,204,220,120, 28, 0,
252,102,102,124,108,102,230, 0,120,204,224,112, 28,204,120, 0,
252,180, 48, 48, 48, 48,120, 0,204,204,204,204,204,204,252, 0,
204,204,204,204,204,120, 48, 0,198,198,198,214,254,238,198, 0,
198,198,108, 56, 56,108,198, 0,204,204,204,120, 48, 48,120, 0,
254,198,140, 24, 50,102,254, 0,120, 96, 96, 96, 96, 96,120, 0,
192, 96, 48, 24, 12, 6, 2, 0,120, 24, 24, 24, 24, 24,120, 0,
16, 56,108,198, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,255,
48, 48, 24, 0, 0, 0, 0, 0, 0, 0,120, 12,124,204,118, 0,
224, 96, 96,124,102,102,220, 0, 0, 0,120,204,192,204,120, 0,
28, 12, 12,124,204,204,118, 0, 0, 0,120,204,252,192,120, 0,
56,108, 96,240, 96, 96,240, 0, 0, 0,118,204,204,124, 12,248,
224, 96,108,118,102,102,230, 0, 48, 0,112, 48, 48, 48,120, 0,
12, 0, 12, 12, 12,204,204,120,224, 96,102,108,120,108,230, 0,
112, 48, 48, 48, 48, 48,120, 0, 0, 0,204,254,254,214,198, 0,
0, 0,248,204,204,204,204, 0, 0, 0,120,204,204,204,120, 0,
0, 0,220,102,102,124, 96,240, 0, 0,118,204,204,124, 12, 30,
0, 0,220,118,102, 96,240, 0, 0, 0,124,192,120, 12,248, 0,
16, 48,124, 48, 48, 52, 24, 0, 0, 0,204,204,204,204,118, 0,
0, 0,204,204,204,120, 48, 0, 0, 0,198,214,254,254,108, 0,
0, 0,198,108, 56,108,198, 0, 0, 0,204,204,204,124, 12,248,
0, 0,252,152, 48,100,252, 0, 28, 48, 48,224, 48, 48, 28, 0,
24, 24, 24, 0, 24, 24, 24, 0,224, 48, 48, 28, 48, 48,224, 0,
118,220, 0, 0, 0, 0, 0, 0, 0, 16, 56,108,198,198,254, 0,
120,204,192,204,120, 24, 12,120, 0,204, 0,204,204,204,126, 0,
28, 0,120,204,252,192,120, 0,126,195, 60, 6, 62,102, 63, 0,
204, 0,120, 12,124,204,126, 0,224, 0,120, 12,124,204,126, 0,
48, 48,120, 12,124,204,126, 0, 0, 0,120,192,192,120, 12, 56,
126,195, 60,102,126, 96, 60, 0,204, 0,120,204,252,192,120, 0,
224, 0,120,204,252,192,120, 0,204, 0,112, 48, 48, 48,120, 0,
124,198, 56, 24, 24, 24, 60, 0,224, 0,112, 48, 48, 48,120, 0,
198, 56,108,198,254,198,198, 0, 48, 48, 0,120,204,252,204, 0,
28, 0,252, 96,120, 96,252, 0, 0, 0,127, 12,127,204,127, 0,
62,108,204,254,204,204,206, 0,120,204, 0,120,204,204,120, 0,
0,204, 0,120,204,204,120, 0, 0,224, 0,120,204,204,120, 0,
120,204, 0,204,204,204,126, 0, 0,224, 0,204,204,204,126, 0,
0,204, 0,204,204,124, 12,248,195, 24, 60,102,102, 60, 24, 0,
204, 0,204,204,204,204,120, 0, 24, 24,126,192,192,126, 24, 24,
56,108,100,240, 96,230,252, 0,204,204,120,252, 48,252, 48, 48,
248,204,204,250,198,207,198,199, 14, 27, 24, 60, 24, 24,216,112,
28, 0,120, 12,124,204,126, 0, 56, 0,112, 48, 48, 48,120, 0,
0, 28, 0,120,204,204,120, 0, 0, 28, 0,204,204,204,126, 0,
0,248, 0,248,204,204,204, 0,252, 0,204,236,252,220,204, 0,
60,108,108, 62, 0,126, 0, 0, 56,108,108, 56, 0,124, 0, 0,
48, 0, 48, 96,192,204,120, 0, 0, 0, 0,252,192,192, 0, 0,
0, 0, 0,252, 12, 12, 0, 0,195,198,204,222, 51,102,204, 15,
195,198,204,219, 55,111,207, 3, 24, 24, 0, 24, 24, 24, 24, 0,
0, 51,102,204,102, 51, 0, 0, 0,204,102, 51,102,204, 0, 0,
34,136, 34,136, 34,136, 34,136, 85,170, 85,170, 85,170, 85,170,
219,119,219,238,219,119,219,238, 24, 24, 24, 24, 24, 24, 24, 24,
24, 24, 24, 24,248, 24, 24, 24, 24, 24,248, 24,248, 24, 24, 24,
54, 54, 54, 54,246, 54, 54, 54, 0, 0, 0, 0,254, 54, 54, 54,
0, 0,248, 24,248, 24, 24, 24, 54, 54,246, 6,246, 54, 54, 54,
54, 54, 54, 54, 54, 54, 54, 54, 0, 0,254, 6,246, 54, 54, 54,
54, 54,246, 6,254, 0, 0, 0, 54, 54, 54, 54,254, 0, 0, 0,
24, 24,248, 24,248, 0, 0, 0, 0, 0, 0, 0,248, 24, 24, 24,
24, 24, 24, 24, 31, 0, 0, 0, 24, 24, 24, 24,255, 0, 0, 0,
0, 0, 0, 0,255, 24, 24, 24, 24, 24, 24, 24, 31, 24, 24, 24,
0, 0, 0, 0,255, 0, 0, 0, 24, 24, 24, 24,255, 24, 24, 24,
24, 24, 31, 24, 31, 24, 24, 24, 54, 54, 54, 54, 55, 54, 54, 54,
54, 54, 55, 48, 63, 0, 0, 0, 0, 0, 63, 48, 55, 54, 54, 54,
54, 54,247, 0,255, 0, 0, 0, 0, 0,255, 0,247, 54, 54, 54,
54, 54, 55, 48, 55, 54, 54, 54, 0, 0,255, 0,255, 0, 0, 0,
54, 54,247, 0,247, 54, 54, 54, 24, 24,255, 0,255, 0, 0, 0,
54, 54, 54, 54,255, 0, 0, 0, 0, 0,255, 0,255, 24, 24, 24,
0, 0, 0, 0,255, 54, 54, 54, 54, 54, 54, 54, 63, 0, 0, 0,
24, 24, 31, 24, 31, 0, 0, 0, 0, 0, 31, 24, 31, 24, 24, 24,
0, 0, 0, 0, 63, 54, 54, 54, 54, 54, 54, 54,255, 54, 54, 54,
24, 24,255, 24,255, 24, 24, 24, 24, 24, 24, 24,248, 0, 0, 0,
0, 0, 0, 0, 31, 24, 24, 24,255,255,255,255,255,255,255,255,
0, 0, 0, 0,255,255,255,255,240,240,240,240,240,240,240,240,
15, 15, 15, 15, 15, 15, 15, 15,255,255,255,255, 0, 0, 0, 0,
0, 0,118,220,200,220,118, 0, 0,120,204,248,204,248,192,192,
0,252,204,192,192,192,192, 0, 0,254,108,108,108,108,108, 0,
252,204, 96, 48, 96,204,252, 0, 0, 0,126,216,216,216,112, 0,
0,102,102,102,102,124, 96,192, 0,118,220, 24, 24, 24, 24, 0,
252, 48,120,204,204,120, 48,252, 56,108,198,254,198,108, 56, 0,
56,108,198,198,108,108,238, 0, 28, 48, 24,124,204,204,120, 0,
0, 0,126,219,219,126, 0, 0, 6, 12,126,219,219,126, 96,192,
56, 96,192,248,192, 96, 56, 0,120,204,204,204,204,204,204, 0,
0,252, 0,252, 0,252, 0, 0, 48, 48,252, 48, 48, 0,252, 0,
96, 48, 24, 48, 96, 0,252, 0, 24, 48, 96, 48, 24, 0,252, 0,
14, 27, 27, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,216,216,112,
48, 48, 0,252, 0, 48, 48, 0, 0,118,220, 0,118,220, 0, 0,
56,108,108, 56, 0, 0, 0, 0, 0, 0, 0, 24, 24, 0, 0, 0,
0, 0, 0, 0, 24, 0, 0, 0, 15, 12, 12, 12,236,108, 60, 28,
120,108,108,108,108, 0, 0, 0,112, 24, 48, 96,120, 0, 0, 0,
0, 0, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
{ Standard Palette entries }
DefaultPalette : Array [0..255] Of RGB =
((r: 0;g: 0;b: 0),(r: 0;g: 0;b: 42),(r: 0;g: 42;b: 0),(r: 0;g: 42;b: 42),
(r: 42;g: 0;b: 0),(r: 42;g: 0;b: 42),(r: 42;g: 21;b: 0),(r: 42;g: 42;b: 42),
(r: 21;g: 21;b: 21),(r: 21;g: 21;b: 63),(r: 21;g: 63;b: 21),(r: 21;g: 63;b: 63),
(r: 63;g: 21;b: 21),(r: 63;g: 21;b: 63),(r: 63;g: 63;b: 21),(r: 63;g: 63;b: 63),
(r: 0;g: 0;b: 0),(r: 5;g: 5;b: 5),(r: 8;g: 8;b: 8),(r: 11;g: 11;b: 11),
(r: 14;g: 14;b: 14),(r: 17;g: 17;b: 17),(r: 20;g: 20;b: 20),(r: 24;g: 24;b: 24),
(r: 28;g: 28;b: 28),(r: 32;g: 32;b: 32),(r: 36;g: 36;b: 36),(r: 40;g: 40;b: 40),
(r: 45;g: 45;b: 45),(r: 50;g: 50;b: 50),(r: 56;g: 56;b: 56),(r: 63;g: 63;b: 63),
(r: 0;g: 0;b: 63),(r: 16;g: 0;b: 63),(r: 31;g: 0;b: 63),(r: 47;g: 0;b: 63),
(r: 63;g: 0;b: 63),(r: 63;g: 0;b: 47),(r: 63;g: 0;b: 31),(r: 63;g: 0;b: 16),
(r: 63;g: 0;b: 0),(r: 63;g: 16;b: 0),(r: 63;g: 31;b: 0),(r: 63;g: 47;b: 0),
(r: 63;g: 63;b: 0),(r: 47;g: 63;b: 0),(r: 31;g: 63;b: 0),(r: 16;g: 63;b: 0),
(r: 0;g: 63;b: 0),(r: 0;g: 63;b: 16),(r: 0;g: 63;b: 31),(r: 0;g: 63;b: 47),
(r: 0;g: 63;b: 63),(r: 0;g: 47;b: 63),(r: 0;g: 31;b: 63),(r: 0;g: 16;b: 63),
(r: 31;g: 31;b: 63),(r: 39;g: 31;b: 63),(r: 47;g: 31;b: 63),(r: 55;g: 31;b: 63),
(r: 63;g: 31;b: 63),(r: 63;g: 31;b: 55),(r: 63;g: 31;b: 47),(r: 63;g: 31;b: 39),
(r: 63;g: 31;b: 31),(r: 63;g: 39;b: 31),(r: 63;g: 47;b: 31),(r: 63;g: 55;b: 31),
(r: 63;g: 63;b: 31),(r: 55;g: 63;b: 31),(r: 47;g: 63;b: 31),(r: 39;g: 63;b: 31),
(r: 31;g: 63;b: 31),(r: 31;g: 63;b: 39),(r: 31;g: 63;b: 47),(r: 31;g: 63;b: 55),
(r: 31;g: 63;b: 63),(r: 31;g: 55;b: 63),(r: 31;g: 47;b: 63),(r: 31;g: 39;b: 63),
(r: 45;g: 45;b: 63),(r: 49;g: 45;b: 63),(r: 54;g: 45;b: 63),(r: 58;g: 45;b: 63),
(r: 63;g: 45;b: 63),(r: 63;g: 45;b: 58),(r: 63;g: 45;b: 54),(r: 63;g: 45;b: 49),
(r: 63;g: 45;b: 45),(r: 63;g: 49;b: 45),(r: 63;g: 54;b: 45),(r: 63;g: 58;b: 45),
(r: 63;g: 63;b: 45),(r: 58;g: 63;b: 45),(r: 54;g: 63;b: 45),(r: 49;g: 63;b: 45),
(r: 45;g: 63;b: 45),(r: 45;g: 63;b: 49),(r: 45;g: 63;b: 54),(r: 45;g: 63;b: 58),
(r: 45;g: 63;b: 63),(r: 45;g: 58;b: 63),(r: 45;g: 54;b: 63),(r: 45;g: 49;b: 63),
(r: 0;g: 0;b: 28),(r: 7;g: 0;b: 28),(r: 14;g: 0;b: 28),(r: 21;g: 0;b: 28),
(r: 28;g: 0;b: 28),(r: 28;g: 0;b: 21),(r: 28;g: 0;b: 14),(r: 28;g: 0;b: 7),
(r: 28;g: 0;b: 0),(r: 28;g: 7;b: 0),(r: 28;g: 14;b: 0),(r: 28;g: 21;b: 0),
(r: 28;g: 28;b: 0),(r: 21;g: 28;b: 0),(r: 14;g: 28;b: 0),(r: 7;g: 28;b: 0),
(r: 0;g: 28;b: 0),(r: 0;g: 28;b: 7),(r: 0;g: 28;b: 14),(r: 0;g: 28;b: 21),
(r: 0;g: 28;b: 28),(r: 0;g: 21;b: 28),(r: 0;g: 14;b: 28),(r: 0;g: 7;b: 28),
(r: 14;g: 14;b: 28),(r: 17;g: 14;b: 28),(r: 21;g: 14;b: 28),(r: 24;g: 14;b: 28),
(r: 28;g: 14;b: 28),(r: 28;g: 14;b: 24),(r: 28;g: 14;b: 21),(r: 28;g: 14;b: 17),
(r: 28;g: 14;b: 14),(r: 28;g: 17;b: 14),(r: 28;g: 21;b: 14),(r: 28;g: 24;b: 14),
(r: 28;g: 28;b: 14),(r: 24;g: 28;b: 14),(r: 21;g: 28;b: 14),(r: 17;g: 28;b: 14),
(r: 14;g: 28;b: 14),(r: 14;g: 28;b: 17),(r: 14;g: 28;b: 21),(r: 14;g: 28;b: 24),
(r: 14;g: 28;b: 28),(r: 14;g: 24;b: 28),(r: 14;g: 21;b: 28),(r: 14;g: 17;b: 28),
(r: 20;g: 20;b: 28),(r: 22;g: 20;b: 28),(r: 24;g: 20;b: 28),(r: 26;g: 20;b: 28),
(r: 28;g: 20;b: 28),(r: 28;g: 20;b: 26),(r: 28;g: 20;b: 24),(r: 28;g: 20;b: 22),
(r: 28;g: 20;b: 20),(r: 28;g: 22;b: 20),(r: 28;g: 24;b: 20),(r: 28;g: 26;b: 20),
(r: 28;g: 28;b: 20),(r: 26;g: 28;b: 20),(r: 24;g: 28;b: 20),(r: 22;g: 28;b: 20),
(r: 20;g: 28;b: 20),(r: 20;g: 28;b: 22),(r: 20;g: 28;b: 24),(r: 20;g: 28;b: 26),
(r: 20;g: 28;b: 28),(r: 20;g: 26;b: 28),(r: 20;g: 24;b: 28),(r: 20;g: 22;b: 28),
(r: 0;g: 0;b: 16),(r: 4;g: 0;b: 16),(r: 8;g: 0;b: 16),(r: 12;g: 0;b: 16),
(r: 16;g: 0;b: 16),(r: 16;g: 0;b: 12),(r: 16;g: 0;b: 8),(r: 16;g: 0;b: 4),
(r: 16;g: 0;b: 0),(r: 16;g: 4;b: 0),(r: 16;g: 8;b: 0),(r: 16;g: 12;b: 0),
(r: 16;g: 16;b: 0),(r: 12;g: 16;b: 0),(r: 8;g: 16;b: 0),(r: 4;g: 16;b: 0),
(r: 0;g: 16;b: 0),(r: 0;g: 16;b: 4),(r: 0;g: 16;b: 8),(r: 0;g: 16;b: 12),
(r: 0;g: 16;b: 16),(r: 0;g: 12;b: 16),(r: 0;g: 8;b: 16),(r: 0;g: 4;b: 16),
(r: 8;g: 8;b: 16),(r: 10;g: 8;b: 16),(r: 12;g: 8;b: 16),(r: 14;g: 8;b: 16),
(r: 16;g: 8;b: 16),(r: 16;g: 8;b: 14),(r: 16;g: 8;b: 12),(r: 16;g: 8;b: 10),
(r: 16;g: 8;b: 8),(r: 16;g: 10;b: 8),(r: 16;g: 12;b: 8),(r: 16;g: 14;b: 8),
(r: 16;g: 16;b: 8),(r: 14;g: 16;b: 8),(r: 12;g: 16;b: 8),(r: 10;g: 16;b: 8),
(r: 8;g: 16;b: 8),(r: 8;g: 16;b: 10),(r: 8;g: 16;b: 12),(r: 8;g: 16;b: 14),
(r: 8;g: 16;b: 16),(r: 8;g: 14;b: 16),(r: 8;g: 12;b: 16),(r: 8;g: 10;b: 16),
(r: 11;g: 11;b: 16),(r: 12;g: 11;b: 16),(r: 13;g: 11;b: 16),(r: 15;g: 11;b: 16),
(r: 16;g: 11;b: 16),(r: 16;g: 11;b: 15),(r: 16;g: 11;b: 13),(r: 16;g: 11;b: 12),
(r: 16;g: 11;b: 11),(r: 16;g: 12;b: 11),(r: 16;g: 13;b: 11),(r: 16;g: 15;b: 11),
(r: 16;g: 16;b: 11),(r: 15;g: 16;b: 11),(r: 13;g: 16;b: 11),(r: 12;g: 16;b: 11),
(r: 11;g: 16;b: 11),(r: 11;g: 16;b: 12),(r: 11;g: 16;b: 13),(r: 11;g: 16;b: 15),
(r: 11;g: 16;b: 16),(r: 11;g: 15;b: 16),(r: 11;g: 13;b: 16),(r: 11;g: 12;b: 16),
(r: 32;g: 32;b: 32),(r: 63;g: 0;b: 0),(r: 0;g: 63;b: 0),(r: 63;g: 63;b: 0),
(r: 0;g: 0;b: 63),(r: 63;g: 0;b: 63),(r: 0;g: 63;b: 63),(r: 63;g: 63;b: 63));
NormalPut = 0; { WriteMode constants (not supported yet) }
NotPut = 1;
AndPut = 2;
OrPut = 3;
XorPut = 4;
SolidFill = 0; { Fillpattern type }
UserDefinedFill = 255;
StdBufferSize = 4096; { Buffer size for graphics functions }
Err_VesaNotSupported = 200; { Errorcodes }
Err_VesaError = 201;
Err_InvalidViewPort = 202;
Err_InvalidFont = 203;
Err_InvalidCharSize = 204;
Err_InvalidFontScale = 205;
Type
Palette2 = Array [0.. 1] Of RGB; { Standard palette structures }
Palette4 = Array [0.. 3] Of RGB;
Palette16 = Array [0.. 15] Of RGB;
Palette256 = Array [0..255] Of RGB;
PFillPatternType = ^FillPatternType;
FillPatternType = Record
Width, Height : Integer;
Data : Array [0..0] Of Byte;
End;
PMGraphics = ^MGraphics; { Pointer to abstract graphics object }
MGraphics = Object { abstract graphics object }
{ Pointer to array of bytes, exactly one scanline in size, }
{ meant for the user to play around with. }
ScanlineBuffer : PByteArray;
Constructor Init (NewGraphicsMode : GraphicsMode);
Destructor Done; Virtual;
{ Virtual methods, redefined by subclasses }
Procedure SetScanline (Scanline, Index, Width : Integer; Var Data); Virtual;
Procedure GetScanline (Scanline, Index, Width : Integer; Var Data); Virtual;
Procedure SetLogicPalEntry (Entry : Word; Color : RGB); Virtual;
Procedure GetLogicPalEntry (Entry : Word; Var Color : RGB); Virtual;
{ Standard graphics functions }
Procedure PutPixel (x, y : Integer; Color : Byte);
Function GetPixel (x, y : Integer) : Byte;
Procedure Line (x1, y1, x2, y2 : Integer);
Procedure LineRel (dx, dy : Integer);
Procedure LineTo (x, y : Integer);
Procedure Rectangle (x1, y1, x2, y2 : Integer);
Procedure Circle (x_center, y_center, radius : Integer);
Procedure Ellipse (x_center, y_center, rx, ry : Integer);
Procedure Arc (x_center, y_center, radius, s_angle, e_angle : Word);
Procedure EllipseArc (x_center, y_center, rx, ry, s_angle, e_angle : Word);
Procedure Curve (x1, y1, x2, y2, x3, y3 : Integer; Segments : Word);
Procedure CubicBezierCurve (x1, y1, x2, y2, x3, y3, x4, y4 : Integer; Segments : Word);
Procedure BSpline (NumPoints : Word; Var Points : Array Of Point; Segments : Word);
Procedure DrawPoly (NumPoints : Word; Var Points : Array Of Point);
Procedure FilledRectangle (x1, y1, x2, y2 : Integer);
Procedure FilledCircle (x_center, y_center, radius : Integer);
Procedure FilledEllipse (x_center, y_center, rx, ry : Integer);
Procedure FilledConvexPoly (NumPoints : Integer; Var Points : Array Of Point; FillColor : Byte);
Procedure FilledConcavePoly (NumPoints : Integer; Var Points : Array Of Point; FillColor : Byte);
Procedure BoundaryFill (x, y : Integer; Boundary, FillColor : Byte);
Procedure FloodFill (x, y : Integer; Flood, FillColor : Byte);
Procedure Paint (x, y, Width, Height : Integer; Color : Byte);
Function ImageSize (Width, Height : Integer) : LongInt;
Procedure GetImage (x, y, Width, Height : Integer; Var ImageData);
Procedure PutImage (x, y : Integer; Var ImageData);
Procedure SetFillPattern (Style : Byte; Var Pattern);
Procedure PrintAt (x, y : Integer; s : String; TextColor, BackColor : Byte);
Procedure Print (s : String; TextColor, BackColor : Byte);
Procedure SetFont (FontPtr : Pointer; FontWidth, FontHeight : Integer);
Procedure SetFontScale (ScaleX, ScaleY : Integer);
Procedure FontScale (Var ScaleX, ScaleY : Integer);
Function CharWidth : Integer;
Function CharHeight : Integer;
Procedure Clear;
Procedure MoveRel (dx, dy : Integer);
Procedure MoveTo (x, y : Integer);
Function GetX : Integer;
Function GetY : Integer;
Procedure SetWriteMode (Mode : Byte);
Procedure SetColor (Color : Byte);
Procedure SetBgColor (Color : Byte);
Function GetColor : Byte;
Function GetBgColor : Byte;
Function GetMaxX : Word;
Function GetMaxY : Word;
Function DeviceMaxX : Word;
Function DeviceMaxY : Word;
Function ColorDepth : Byte;
Procedure SetViewport (MinX, MinY, MaxX, MaxY : Integer);
Procedure GetViewport (Var MinX, MinY, MaxX, MaxY : Integer);
{ Color functions }
Procedure SetLogicPalette (From, NumberOf : Integer; Entries : Array Of RGB);
Procedure GetLogicPalette (From, NumberOf : Integer; Var Entries : Array Of RGB);
Private
Graphics_Mode : GraphicsMode; { Current video mode }
LastGraphicsMode : Word; { Video mode before initialization }
Buffer : Record { Union for byte and word addressing of buffer }
ByteIndex : Word;
WordIndex : Word;
Case Boolean Of
False : (Bytes : Array [0..StdBufferSize-1] Of Byte);
True : (Words : Array [0..(StdBufferSize DIV 2)-1] Of Word);
End;
Font : PByteArray; { Pointer to current font }
FontScaleX, FontScaleY : Integer; { Multiplication factors for fontwidth/height }
CharDX, CharDY : Integer; { Dimensions of characters in current font }
s1, s2, s3 : PByteArray; { Three buffers for scanlines }
FillStyle : Byte; { Filling method (solid, userdefined) }
FillPattern : PFillPatternType; { Pointer to current fill pattern }
CP : Point; { Graphic 'cursor' position }
VMinX, VMinY, VMaxX, VMaxY : Integer; { Coordinates of viewport }
FgColor, BgColor : Byte; { Fore and background colors }
WriteMode : Byte; { WriteMode (Normal, Not, Xor, And, Or ) }
Regs : Registers; { General purpose register structure }
LastDev : Text; { Variable to store the old output device }
Function CheckClip (Var Scanline, Index, Width, Offset : Integer) : Boolean;
Procedure GetScanlinePattern (y, x, Width : Integer; Var Data);
Procedure PushPoint (x, y : Integer);
Procedure PopPoint (Var x, y : Integer);
End;
MGenericCard = Object (MGraphics)
Constructor Init (NewGraphicsMode : GraphicsMode; ClearMem : Boolean);
Destructor Done; Virtual;
Procedure SetScanline (Scanline, Index, Width : Integer; Var Data); Virtual;
Procedure GetScanline (Scanline, Index, Width : Integer; Var Data); Virtual;
Procedure SetLogicPalEntry (Entry : Word; Color : RGB); Virtual;
Procedure GetLogicPalEntry (Entry : Word; Var Color : RGB); Virtual;
End;
MVGACard = Object (MGenericCard)
Constructor Init (NewGraphicsMode : GraphicsMode; ClearMem : Boolean);
Destructor Done; Virtual;
Procedure SetScanline (Scanline, Index, Width : Integer; Var Data); Virtual;
Procedure GetScanline (Scanline, Index, Width : Integer; Var Data); Virtual;
Procedure SetLogicPalEntry (Entry : Word; Color : RGB); Virtual;
Procedure GetLogicPalEntry (Entry : Word; Var Color : RGB); Virtual;
End;
MSuperVGACard = Object (MVGACard) { Abstract class, don't use directly! }
Procedure SetScanline (Scanline, Index, Width : Integer; Var Data); Virtual;
Procedure GetScanline (Scanline, Index, Width : Integer; Var Data); Virtual;
Procedure SetBank (Bank : Word); Virtual;
Function GetBank : Word; Virtual;
Procedure SetGranularity (Granularity : Word);
Private
Grain : LongInt;
End;
{$IFNDEF DPMI}
MVesaCard = Object (MSuperVGACard)
Constructor Init (NewGraphicsMode : GraphicsMode; ClearMem : Boolean);
Destructor Done; Virtual;
Procedure SetBank (Bank : Word); Virtual;
Function GetBank : Word; Virtual;
Private
VesaInfo : Record
ModeAttr : Word; A_WinAttr : Byte; B_WinAttr : Byte;
WinGrain : Word; WinSize : Word; A_StartSeg : Word;
B_StartSeg : Word; BankSwitcher : Pointer; ScanlineBytes : Word;
ScreenWidth : Word; ScreenHeight : Word; CharWidth : Byte;
CharHeight : Byte; MemoryPlanes : Byte; BitsPerPixel : Byte;
Banks : Byte; MemoryModel : Byte; BankSize : Byte;
ImagePlanes : Byte;
Reserved : Array [1..226] Of Byte;
End;
Function VesaError : Boolean;
End;
{$ENDIF}
MTsengET4000Card = Object (MSuperVGACard)
Constructor Init (NewGraphicsMode : GraphicsMode; ClearMem : Boolean);
Procedure SetBank (Bank : Word); Virtual;
Function GetBank : Word; Virtual;
End;
Implementation
Const
Module_ID = 'Graphics';
RadToDeg = 180/Pi;
DegToRad = 1/RadToDeg;
SmallValue = 1e-8;
{$F+} { have to be far }
Function DevDummy (Var f : TextRec) : Integer;
Begin
DevDummy:=0;
End;
Function DevOut (Var f : TextRec) : Integer;
Var
s : String;
Card : PMGraphics;
Begin
Move (f.Buffer,s[1],f.BufPos);
s[0]:=Chr (f.BufPos);
Move (f.UserData,Card,4);
Card^.Print (s,Card^.GetColor,Card^.GetBgColor);
f.BufPos:=0;
DevOut:=0;
End;
{$F-}
Constructor MGraphics.Init (NewGraphicsMode : GraphicsMode);
Var
p : Pointer;
Begin
Graphics_Mode:=NewGraphicsMode;
{ Claim memory for three scanlines }
GetMem (s1,Graphics_Mode.Width);
GetMem (s2,Graphics_Mode.Width);
GetMem (s3,Graphics_Mode.Width);
GetMem (ScanlineBuffer,Graphics_Mode.Width);
{ If not succesfull, fail to construct }
If Not Assigned (s1) Or Not Assigned (s2) Or Not Assigned (s3) Or
Not Assigned (ScanlineBuffer) then Fail;
{ Install rom font }
SetFont (@DefaultFont,8,8);
{ Install solid fillpattern }
SetFillPattern (SolidFill,p);
{ Initial clipping window is equal to the entire display }
SetViewport (0,0,DeviceMaxX,DeviceMaxY);
{ Setup initial colors }
FgColor:=15; { foreground color }
BgColor:=0; { background color }
CP.x:=0; { initial 'cursor' position }
CP.y:=0;
{ Setup standard output to enable user to put text on the screen using the }
{ standard write(ln) statements. }
TextRec (LastDev):=TextRec (Output);
With TextRec (Output) Do Begin
Handle:=$FFFF;
Mode:=fmOutput;
BufSize:=SizeOf (Buffer);
BufPtr:=@Buffer;
Name[0]:=#0;
p:=@Self;
Move (p,UserData,4);{ Put 32-bit pointer to graphics object in device }
OpenFunc:=@DevDummy;
InOutFunc:=@DevOut;
FlushFunc:=@DevOut;
CloseFunc:=@DevDummy;
End;
End;
Destructor MGraphics.Done;
Begin
{ Deallocate memory }
If Assigned (s1) then FreeMem (s1,Graphics_Mode.Width);
If Assigned (s2) then FreeMem (s2,Graphics_Mode.Width);
If Assigned (s3) then FreeMem (s3,Graphics_Mode.Width);
If Assigned (ScanlineBuffer) then FreeMem (ScanlineBuffer,Graphics_Mode.Width);
s1:=NIL; s2:=NIL; s3:=NIL; ScanlineBuffer:=NIL;
TextRec (Output):=TextRec (LastDev);
End;
Procedure MGraphics.SetScanline (Scanline, Index, Width : Integer; Var Data);
Begin
RunError (211); { Abstract class so no direct calls }
End;
Procedure MGraphics.GetScanline (Scanline, Index, Width : Integer; Var Data);
Begin
RunError (211); { Abstract class so no direct calls }
End;
Procedure MGraphics.SetLogicPalEntry (Entry : Word; Color : RGB);
Begin
RunError (211); { Abstract class so no direct calls }
End;
Procedure MGraphics.GetLogicPalEntry (Entry : Word; Var Color : RGB);
Begin
RunError (211); { Abstract class so no direct calls }
End;
Procedure MGraphics.PutPixel (x, y : Integer; Color : Byte);
{ Putpixel puts a pixel on the screen on position (x,y) with color 'Color' }
Begin
SetScanline (y,x,1,Color);
End;
Function MGraphics.GetPixel (x, y : Integer) : Byte;
{ return pixelvalue at position (x,y) }
Var
Color : Byte;
Begin
GetScanline (y,x,1,Color);
GetPixel:=Color;
End;
Procedure MGraphics.Line (x1, y1, x2, y2 : Integer);
{ Draw a line from (x1,y1) to (x2,y2). No restrictions are placed on these }
{ input values. (so x1>x2 is no problem) }
Var
d, ax, ay, sx, sy, dx, dy : Integer;
Begin
{ bressenham line algorithm uses only integer arithmetic }
dx := x2-x1; ax := Abs (dx) SHL 1; If dx<0 then sx:=-1 Else sx:=1;
dy := y2-y1; ay := Abs (dy) SHL 1; If dy<0 then sy:=-1 Else sy:=1;
PutPixel (x1, y1, FgColor);
If ax>ay then Begin
d:=ay-(ax SHR 1);
While x1<>x2 Do Begin
If d>=0 then Begin Inc (y1,sy); Dec (d,ax); End;
Inc (x1,sx);
Inc (d,ay);
PutPixel (x1, y1, FgColor);
End;
End
Else Begin
d:=ax-(ay SHR 1);
While y1<>y2 Do Begin
If d>=0 then Begin Inc (x1,sx); Dec (d,ay); End;
Inc (y1,sy);
Inc (d,ax);
PutPixel (x1, y1, FgColor);
End;
End;
End;
Procedure MGraphics.LineRel (dx, dy : Integer);
Begin
Line (CP.x,CP.y,CP.x+dx,CP.y+dy);
Inc (CP.x,dx);
Inc (CP.y,dy);
End;
Procedure MGraphics.LineTo (x, y : Integer);
Begin
Line (CP.x,CP.y,x,y);
CP.x:=x;
CP.y:=y;
End;
Procedure MGraphics.Rectangle (x1, y1, x2, y2 : Integer);
{ Draw a rectangle with upperleft corner (x1,y1) and lowerright corner (x2,y2) }
{ When other writemode are implemented this algorithm has to be changed as }
{ the corner pointer are plot more than once, which causes problems in other }
{ writemodes }
Begin
Line (x1,y1,x2,y1);
Line (x2,y1,x2,y2);
Line (x2,y2,x1,y2);
Line (x1,y2,x1,y1);
End;
Procedure MGraphics.Circle (x_center, y_center, radius : Integer);
{ Draw a circle with center (x_center,y_center) and radius 'radius' }
Var
x, y, d : Integer;
Begin
{ bressenham circle algorithm using integer-only arithmetic }
x:=0; y:=radius; d:=2*(1-radius);
While y>=0 Do Begin
PutPixel (x_center+x,y_center+y,FgColor);
PutPixel (x_center+x,y_center-y,FgColor);
PutPixel (x_center-x,y_center+y,FgColor);
PutPixel (x_center-x,y_center-y,FgColor);
If d + y > 0 then Begin
Dec (y);
Dec (d,2*y+1);
End;
If x > d then Begin
Inc (x);
Inc (d,2*x+1);
End;
End;
End;
Procedure MGraphics.Ellipse (x_center, y_center, rx, ry : Integer);
{ Draw an Ellipse with center (x_center,y_center), horizontal radius 'rx' }
{ and vertical radius 'ry'. This algorithm partially uses floating point }
{ arithmetic to still get an accurate ellipse when rx or ry is small ! }
Var
x, y, x2, dx : Integer;
Sqrry : LongInt;
rxryDiv : Real;
Begin
FillChar (s1^,1+DeviceMaxX,FgColor);
Dec(ry);
If ry>0 then Begin
Sqrry:=Sqr (LongInt (ry));
rxryDiv:=rx/ry;
X2:=rx;
For y:=0 to ry Do Begin
x:=Round (rxryDiv*Sqrt(Sqrry-Sqr(y-0.5)));
If x<>x2 then Begin
dx:=1+x2-x;
SetScanline (y_center+y,x_center+x,dx,s1^);
SetScanline (y_center+y,x_center-x2,dx,s1^);
SetScanline (y_center-y,x_center+x,dx,s1^);
SetScanline (y_center-y,x_center-x2,dx,s1^);
End
Else Begin
SetScanline (y_center+y,x_center+x,1,s1^);
SetScanline (y_center+y,x_center-x2,1,s1^);
SetScanline (y_center-y,x_center+x,1,s1^);
SetScanline (y_center-y,x_center-x2,1,s1^);
End;
x2:=x;
End;
End
Else x:=rx;
Inc(ry);
SetScanline (y_center+ry,x_center-x,2*x+1,s1^);
SetScanline (y_center-ry,x_center-x,2*x+1,s1^);
End;
Procedure MGraphics.Arc (x_center, y_center, radius, s_angle, e_angle : Word);
{ An algorithm to draw an arc. Crude but it works (anyone have a better one?) }
Var
p : Integer;
x, y : Word;
Alpha : Real;
Begin
If radius=0 then Begin PutPixel (x_center,y_center,FgColor); Exit; End;
s_angle:=s_angle MOD 361;
e_angle:=e_angle MOD 361;
If s_angle>e_angle then Begin
s_angle:=s_angle Xor e_angle; e_angle:=e_angle Xor s_angle; s_angle:=e_angle Xor s_angle;
End;
x:=0;
y:=Radius;
p:=3-2*Radius;
While x<=y Do
Begin
Alpha:=RadToDeg*Arctan (x/y);
If (Alpha>=s_angle) And (Alpha<=e_angle) then PutPixel (x_center-x, y_center-y, FgColor);
If (90-Alpha>=s_angle) And (90-Alpha<=e_angle) then PutPixel (x_center-y, y_center-x, FgColor);
If (90+Alpha>=s_angle) And (90+Alpha<=e_angle) then PutPixel (x_center-y, y_center+x, FgColor);
If (180-Alpha>=s_angle) And (180-Alpha<=e_angle) then PutPixel (x_center-x, y_center+y, FgColor);
If (180+Alpha>=s_angle) And (180+Alpha<=e_angle) then PutPixel (x_center+x, y_center+y, FgColor);
If (270-Alpha>=s_angle) And (270-Alpha<=e_angle) then PutPixel (x_center+y, y_center+x, FgColor);
If (270+Alpha>=s_angle) And (270+Alpha<=e_angle) then PutPixel (x_center+y, y_center-x, FgColor);
If (360-Alpha>=s_angle) And (360-Alpha<=e_angle) then PutPixel (x_center+x, y_center-y, FgColor);
If p<0 then
p:=p+4*x+6
Else
Begin
p:=p+4*(x-y)+10;
Dec (y);
End;
Inc (x);
End;
End;
Procedure MGraphics.EllipseArc (x_center, y_center, rx, ry, s_angle, e_angle : Word);
{ Draw an ellipse arc. Crude but it works (anyone have a better one?) }
Var
aSqr, bSqr, twoaSqr, twobSqr, x, y, twoXbSqr, twoYaSqr, error : LongInt;
Alpha : Real;
Procedure PlotPoints;
Begin
If (Alpha>=s_angle) And (Alpha<=e_angle) then PutPixel (x_center-x,y_center-y,FgColor);
If (180-Alpha>=s_angle) And (180-Alpha<=e_angle) then PutPixel (x_center-x,y_center+y,FgColor);
If (180+Alpha>=s_angle) And (180+Alpha<=e_angle) then PutPixel (x_center+x,y_center+y,FgColor);
If (360-Alpha>=s_angle) And (360-Alpha<=e_angle) then PutPixel (x_center+x,y_center-y,FgColor);
End;
Begin
If rx=0 then Begin
Line (x_center,y_center-ry,x_center,y_center+ry);
Exit;
End;
s_angle:=s_angle MOD 361;
e_angle:=e_angle MOD 361;
If s_angle>e_angle then Begin
s_angle:=s_angle Xor e_angle; e_angle:=e_angle Xor s_angle; s_angle:=e_angle Xor s_angle;
End;
aSqr:=LongInt (rx)*LongInt (rx);
bSqr:=LongInt (ry)*LongInt (ry);
twoaSqr:=2*aSqr;
twobSqr:=2*bSqr;
x:=0;
y:=ry;
twoXbSqr:=0;
twoYaSqr:=y*twoaSqr;
error:=-y*aSqr;
While twoXbSqr<=twoYaSqr Do Begin
If y=0 then Alpha:=90 Else Alpha:=RadToDeg*Arctan (x/y); { Crude but it works }
PlotPoints;
Inc (x);
Inc (twoXbSqr,twobSqr);
Inc (error,twoXbSqr-bSqr);
If error>=0 then Begin
Dec (y);
Dec (twoYaSqr,twoaSqr);
Dec (error,twoYaSqr);
End;
End;
x:=rx;
y:=0;
twoXbSqr:=x*twobSqr;
twoYaSqr:=0;
error:=-x*bSqr;
While twoXbSqr>twoYaSqr Do Begin
If y=0 then Alpha:=90 Else Alpha:=RadToDeg*Arctan (x/y);
PlotPoints;
Inc (y);
Inc (twoYaSqr,twoaSqr);
Inc (error,twoYaSqr-aSqr);
If error>=0 then Begin
Dec (x);
Dec (twoXbSqr,twobSqr);
Dec (error,twoXbSqr);
End;
End;
End;
Procedure MGraphics.Curve (x1, y1, x2, y2, x3, y3 : Integer; Segments : Word);
{ Draw a curve from (x1,y1) through (x2,y2) to (x3,y3) divided in 'Segments' segments }
Var
lsteps, ex, ey, fx, fy : LongInt;
t1, t2 : Integer;
Begin
x2:=(x2 SHL 1)-((x1+x3) SHR 1);
y2:=(y2 SHL 1)-((y1+y3) SHR 1);
lsteps:=Segments;
If (lsteps<2) then lsteps:=2;
If (lsteps>128) then lsteps:=128; { Clamp value to avoid overcalculation }
ex:=(LongInt (x2-x1) SHL 17) DIV lsteps;
ey:=(LongInt (y2-y1) SHL 17) DIV lsteps;
fx:=(LongInt (x3-(2*x2)+x1) SHL 16) DIV (lsteps*lsteps);
fy:=(LongInt (y3-(2*y2)+y1) SHL 16) DIV (lsteps*lsteps);
Dec (lsteps);
While lsteps>0 Do Begin
t1:=x3;
t2:=y3;
x3:=(((fx*lsteps+ex)*lsteps) SHR 16)+x1;
y3:=(((fy*lsteps+ey)*lsteps) SHR 16)+y1;
Line (t1,t2,x3,y3);
Dec (lsteps);
End;
Line (x3,y3,x1,y1);
End;
Procedure MGraphics.CubicBezierCurve (x1, y1, x2, y2, x3, y3, x4, y4 : Integer; Segments : Word);
{ Draw a cubic bezier-curve directly using the basis functions }
Var
tx1, tx2, tx3, ty1, ty2, ty3, mu, mu2, mu3, mudelta : Real;
xstart, ystart, xend, yend, n : Integer;
Begin
If (Segments<1) then Exit;
If Segments>128 then Segments:=128;
mudelta:=1/Segments;
mu:=0;
tx1:=-x1+3*x2-3*x3+x4; ty1:=-y1+3*y2-3*y3+y4;
tx2:=3*x1-6*x2+3*x3; ty2:=3*y1-6*y2+3*y3;
tx3:=-3*x1+3*x2; ty3:=-3*y1+3*y2;
xstart:=x1;
ystart:=y1;
mu:=mu+mudelta;
For n:=1 to Segments Do Begin
mu2:=mu*mu;
mu3:=mu2*mu;
xend:=Round (mu3*tx1+mu2*tx2+mu*tx3+x1);
yend:=Round (mu3*ty1+mu2*ty2+mu*ty3+y1);
Line (xstart, ystart, xend, yend);
mu:=mu+mudelta;
xstart:=xend;
ystart:=yend;
End;
End;
Procedure MGraphics.BSpline (NumPoints : Word; Var Points : Array Of Point; Segments : Word);
{ Draw a BSpline approximating a curve defined by the array of points. }
{ Beware! A B-Spline generaly does not normally pass through the points}
{ defining it ! }
Function Calculate (mu : Real; p0, p1, p2, p3 : Integer) : Integer;
Var
mu2, mu3 : Real;
Begin
mu2:=mu*mu;
mu3:=mu2*mu;
Calculate:=Round ((1/6)*(mu3*(-p0+3*p1-3*p2+p3)+
mu2*(3*p0-6*p1+3*p2)+
mu *(-3*p0+3*p2)+(p0+4*p1+p2)));
End;
Var
mu, mudelta : Real;
x1, y1, x2, y2, n, h : Integer;
Begin
If (NumPoints<4) Or (NumPoints>16383) then Exit;
mudelta:=1/Segments;
For n:=3 to NumPoints-1 Do Begin
mu:=0;
x1:=Calculate (mu,Points[n-3].x,Points[n-2].x,Points[n-1].x,Points[n].x);
y1:=Calculate (mu,Points[n-3].y,Points[n-2].y,Points[n-1].y,Points[n].y);
mu:=mu+mudelta;
For h:=1 to Segments Do Begin
x2:=Calculate (mu,Points[n-3].x,Points[n-2].x,Points[n-1].x,Points[n].x);
y2:=Calculate (mu,Points[n-3].y,Points[n-2].y,Points[n-1].y,Points[n].y);
Line (x1, y1, x2, y2);
mu:=mu+mudelta;
x1:=x2;
y1:=y2;
End;
End;
End;
Procedure MGraphics.DrawPoly (NumPoints : Word; Var Points : Array Of Point);
{ Draw the outline of a polygon }
Var
n : Word;
Begin
If (NumPoints=0) Or (NumPoints>16383) then Exit;
For n:=0 to NumPoints-1 Do Begin
Line (Points[n].x,Points[n].y,Points[(n+1) MOD NumPoints].x,Points[(n+1) MOD NumPoints].y);
End;
End;
Procedure MGraphics.FilledRectangle (x1, y1, x2, y2 : Integer);
{ Draw a filled rectangle }
Begin
If x1<=x2 then
If y1=0 Do Begin
Paint (x_center-x,y_center+y,1+2*x,1,FgColor);
Paint (x_center-x,y_center-y,1+2*x,1,FgColor);
If d+y > 0 then Begin
Dec (y);
Dec (d,2*y+1);
End;
If x > d then Begin
Inc (x);
Inc (d,2*x+1);
End;
End;
End;
Procedure MGraphics.FilledEllipse (x_center, y_center, rx, ry : Integer);
{ Draw a filled ellipse }
Var
x, y, x2, dx : Integer;
Sqrry : LongInt;
rxryDiv : Real;
Begin
Dec(ry);
If ry>0 then Begin
Sqrry:=Sqr (LongInt (ry));
rxryDiv:=rx/ry;
X2:=rx;
For y:=0 to ry Do Begin
x:=Round (rxryDiv*Sqrt(Sqrry-Sqr(y-0.5)));
Paint (x_center-x2,y_center+y,1+x+x2,1,FgColor);
Paint (x_center-x2,y_center-y,1+x+x2,1,FgColor);
x2:=x;
End;
End
Else x:=rx;
Inc (ry);
Paint (x_center-x,y_center+ry,2*x+1,1,FgColor);
Paint (x_center-x,y_center-ry,2*x+1,1,FgColor);
End;
Procedure MGraphics.FilledConvexPoly (NumPoints : Integer; Var Points : Array Of Point; FillColor : Byte);
{ Draw a filled CONVEX poly, using the same arithmetic as the bressenham }
{ line algorithm to produce accurately filled polygon. A polygon is }
{ convex when every path between any two points defining the polygon lies}
{ inside that polygon. (translation : don't use weird shapes :) ) }
Type
LineData = Record Index, x, y, dy, d, ax, ay, sx : Integer; End;
Var
Min_y, Smallest, n, ToDo : Integer;
First, Second : LineData;
Procedure InitPolyline (Var Data : LineData; p1, p2 : Integer);
Begin
If p1<0 then p1:=NumPoints+p1; p1:=p1 MOD NumPoints;
If p2<0 then p2:=NumPoints+p2; p2:=p2 MOD NumPoints;
Data.x:=Points[p1].x;
Data.y:=Points[p1].y;
If Points[p2].x16383) then Exit;
FillChar (s1^,1+DeviceMaxX,FillColor);
Smallest:=0;
Min_y:=Points[0].y;
For n:=0 to NumPoints-1 Do
If Points[n].y=0 Do Begin
If First.x=0) And (ay<>0) Do Begin Inc (x,sx); Dec (d,ay); End;
Inc (d,ax);
Dec (dy);
Inc (y);
End;
With Second Do Begin
While (d>=0) And (ay<>0) Do Begin Inc (x,sx); Dec (d,ay); End;
Inc (d,ax);
Dec (dy);
Inc (y);
End;
If First.dy<=0 then Begin
InitPolyline (First,First.Index+1,First.Index+2);
Dec (Todo);
End;
If Second.dy<=0 then Begin
InitPolyline (Second,Second.Index-1,Second.Index-2);
Dec (ToDo);
End;
End;
End;
Procedure MGraphics.FilledConcavePoly (NumPoints : Integer; Var Points : Array Of Point; FillColor : Byte);
{ Draw a filled concave polygon using floating point arithmetic : less accurate }
{ but able to fill ANY polygon, not just convex ones. }
Type
XValueType = Array [0..32766] Of Integer;
Var
MaxIndex, Min_y, Max_y, Index, n, h, i, j, k, l : Integer;
m : Real;
XValue : ^XValueType;
Procedure QuickSort (l, r : Integer);
{ Quicksort to sort the X-Values fast }
Var
i, j, x, y : Integer;
Begin
i:=l; j:=r; x:=XValue^[(l+r) DIV 2];
REPEAT
While XValue^[i]j;
If l16383) then Exit;
FillChar (s1^,1+DeviceMaxX,FillColor);
MaxIndex:=StdBufferSize DIV 2;
XValue:=@Buffer;
Min_y:=Graphics_Mode.Height-1;
Max_y:=0;
For n:=0 to NumPoints-1 Do Begin
If Points[n].yMax_y then Max_y:=Points[n].y;
End;
For n:=Min_y to Max_y Do Begin
Index:=0;
For i:=0 to NumPoints-1 Do Begin
l:=(i+1) MOD NumPoints;
h:=Points[i].y; j:=Points[l].y;
If h>j then Begin k:=h; h:=j; j:=k; End;
If (h<=n) And (n0 then QuickSort (0,Index-1);
j:=0;
While (jGetMaxX) Or (y>GetMaxY) then Exit;
Buffer.WordIndex:=0;
PushPoint (x,y);
While Buffer.WordIndex>0 Do Begin
PopPoint (x,y);
GetScanline (y,0,Graphics_Mode.Width,s1^);
GetScanline (y-1,0,Graphics_Mode.Width,s2^);
GetScanline (y+1,0,Graphics_Mode.Width,s3^);
While Not (s1^[x] IN [Boundary,FillColor]) And (x<=GetMaxX) Do Inc (x);
d:=0;
e:=0;
Dec (x);
Beginx:=x;
REPEAT
If y0 then Begin
Equal:=s2^[x] IN [Boundary,FillColor];
If (d=0) And Not Equal then Begin
PushPoint (x,y-1);
d:=1;
End
Else
If (d=1) And Equal then d:=0;
End;
Dec (x);
Until (x<0) Or (s1^[x]=Boundary);
Paint (x+1,y,Beginx-x,1,FillColor);
End;
End;
Procedure MGraphics.FloodFill (x, y : Integer; Flood, FillColor : Byte);
{ Fill a region of the screen bounded by any color not equal to color 'Flood' }
Var
Beginx : Integer;
d, e, a : Byte;
Cont : Boolean;
Begin
If (x<0) Or (y<0) Or (x>GetMaxX) Or (y>GetMaxY) then Exit;
Buffer.WordIndex:=0;
PushPoint (x,y);
While Buffer.WordIndex>0 Do Begin
PopPoint (x,y);
GetScanline (y-1,0,Graphics_Mode.Width,s2^);
GetScanline (y,0,Graphics_Mode.Width,s1^);
GetScanline (y+1,0,Graphics_Mode.Width,s3^);
While (s1^[x]=Flood) And (x<=GetMaxX) Do Inc (x);
d:=0;
e:=0;
Dec (x);
Beginx:=x;
REPEAT
If yFillColor);
If (e=0) And Cont then Begin
PushPoint (x,y+1);
e:=1;
End
Else
If (e=1) And Not Cont then e:=0;
End;
If y>0 then Begin
Cont:=(s2^[x]=Flood) And (s2^[x]<>FillColor);
If (d=0) And Cont then Begin
PushPoint (x,y-1);
d:=1;
End
Else
If (d=1) And Not Cont then d:=0;
End;
Dec (x);
Until (x<0) Or (s1^[x]<>Flood);
Paint (x+1,y,Beginx-x,1,FillColor);
End;
End;
Procedure MGraphics.Paint (x, y, Width, Height : Integer; Color : Byte);
{ Fill a region of the screen with color 'Color' }
Var
n : Integer;
Begin
If Width>1+DeviceMaxX then Width:=1+DeviceMaxX;
If FillStyle<>UserDefinedFill then FillChar (s1^,Width,Color);
For n:=y to y+Height-1 Do Begin
If FillStyle=UserDefinedFill then GetScanlinePattern (n,x,Width,s1^);
SetScanline (n,x,Width,s1^);
End;
End;
Function MGraphics.ImageSize (Width, Height : Integer) : LongInt;
Begin
ImageSize:=4+LongInt(Width)*LongInt(Height);
End;
Procedure MGraphics.GetImage (x, y, Width, Height : Integer; Var ImageData);
{ 'Get' an image from the screen an put it in the given stream. The image }
{ must not consume more than 64 Kb of memory. If it does, use }
{ GetLargeImage instead. }
Var
Image : Record
Width, Height : Integer;
Data : Array [0..0] Of Byte;
End ABSOLUTE ImageData;
Index : Word;
Begin
If (Width<=0) Or (Height<=0) Or (LongInt(Width)*LongInt(Height)>65528) then Exit;
Image.Width:=Width;
Image.Height:=Height;
Index:=0;
For y:=y to y+Height-1 Do Begin
GetScanline (y,x,Width,Image.Data[Index]);
Inc (Index,Width);
End;
End;
Procedure MGraphics.PutImage (x, y : Integer; Var ImageData);
{ 'Put' an image on the screen at (x,y) }
Var
Image : Record
Width, Height : Integer;
Data : Array [0..0] Of Byte;
End ABSOLUTE ImageData;
Index : Word;
Begin
Index:=0;
For y:=y to y+Image.Height-1 Do Begin
SetScanline (y,x,Image.Width,Image.Data[Index]);
Inc (Index,Image.Width);
End;
End;
Procedure MGraphics.SetFillPattern (Style : Byte; Var Pattern);
{ Install either a user defined fill pattern or a standard pattern }
Begin
Case Style Of
SolidFill : ;
UserDefinedFill : FillPattern:=@Pattern;
Else
Exit;
End;
FillStyle:=Style;
End;
Procedure MGraphics.PrintAt (x, y : Integer; s : String; TextColor, BackColor : Byte);
{ Put the given string on the screen using the current font }
Var
ByteRange, c, n, h, i : Integer;
DataIndex, Index, Size : Word;
b : Byte;
Begin
If Font=NIL then Exit;
Size:=FontScaleX*CharDX;
ByteRange:=1+((CharDX-1) SHR 3);
For c:=1 to Length (s) Do Begin
Index:=Ord (s[c])*(ByteRange)*CharDY-1;
i:=y;
For n:=0 to CharDY-1 Do Begin
DataIndex:=0;
For h:=0 to CharDX-1 Do Begin
If (h And 7)=0 then Begin Inc (Index); b:=Font^[Index]; End;
If b>=128 then
FillChar (s1^[DataIndex],FontScaleX,TextColor)
Else
FillChar (s1^[DataIndex],FontScaleX,BackColor);
Inc (DataIndex,FontScaleX);
b:=b SHL 1;
End;
For h:=0 to FontScaleY-1 Do
SetScanline (i+h,x+Size*(c-1),Size,s1^);
Inc (i,FontScaleY);
End;
End;
End;
Procedure MGraphics.Print (s : String; TextColor, BackColor : Byte);
{ Put the given string on the screen using the current font }
Begin
PrintAt (CP.x,CP.y,s,TextColor,BackColor);
Inc (CP.x,Length (s)*CharDX);
End;
Procedure MGraphics.SetFont (FontPtr : Pointer; FontWidth, FontHeight : Integer);
{ Install a new font }
Begin
If Not Assigned (FontPtr) Or (FontWidth=0) Or (FontHeight=0) then Exit;
Font:=FontPtr;
CharDX:=FontWidth;
CharDY:=FontHeight;
SetFontScale (1,1);
End;
Procedure MGraphics.SetFontScale (ScaleX, ScaleY : Integer);
Begin
If (ScaleX=0) Or (ScaleY=0) then Exit;
FontScaleX:=ScaleX;
FontScaleY:=ScaleY;
End;
Procedure MGraphics.FontScale (Var ScaleX, ScaleY : Integer);
Begin
ScaleX:=FontScaleX;
ScaleY:=FontScaleY;
End;
Function MGraphics.CharWidth : Integer;
{ Return the width of a character in the current font }
Begin
If Font=NIL then CharWidth:=0 Else CharWidth:=CharDX*FontScaleX;
End;
Function MGraphics.CharHeight : Integer;
{ Return the height of a character in the current font }
Begin
If Font=NIL then CharHeight:=0 Else CharHeight:=CharDY*FontScaleY;
End;
Procedure MGraphics.SetColor (Color : Byte);
{ Set the foreground color }
Begin
FgColor:=Color;
End;
Procedure MGraphics.SetBgColor (Color : Byte);
{ Set the background color }
Begin
BgColor:=Color;
End;
Function MGraphics.GetColor : Byte;
{ Return the current foreground color }
Begin
GetColor:=FgColor;
End;
Function MGraphics.GetBgColor : Byte;
{ Return the current background color }
Begin
GetBgColor:=BgColor;
End;
Function MGraphics.GetMaxX : Word;
{ Return the highest possible x-coordinate of the current viewport }
Begin
GetMaxX:=VMaxX-VMinX;
End;
Function MGraphics.GetMaxY : Word;
{ Return the highest possible y-coordinate of the current viewport }
Begin
GetMaxY:=VMaxY-VMinY;
End;
Function MGraphics.DeviceMaxX : Word;
{ Return the highest possible x-coordinate on the current device }
Begin
DeviceMaxX:=Graphics_Mode.Width-1;
End;
Function MGraphics.DeviceMaxY : Word;
{ Return the highest possible y-coordinate on the current device }
Begin
DeviceMaxY:=Graphics_Mode.Height-1;
End;
Function MGraphics.ColorDepth : Byte;
{ Return the colordepth of the current device }
Begin
ColorDepth:=Graphics_Mode.ColorDepth;
End;
Procedure MGraphics.SetViewport (MinX, MinY, MaxX, MaxY : Integer);
{ Set the current viewport }
Var
WrongViewPort : Boolean;
Begin
WrongViewPort:=(MinX<0) Or (MinY<0) Or (MaxX<0) Or (MaxY<0);
WrongViewPort:=WrongViewPort Or ((MinX>MaxX) Or (MinY>MaxY));
WrongViewPort:=WrongViewPort Or ((MaxX>=Graphics_Mode.Width) Or (MaxY>=Graphics_Mode.Height));
If Not WrongViewPort then Begin
VMinX:=MinX;
VMinY:=MinY;
VMaxX:=MaxX;
VMaxY:=MaxY;
End;
End;
Procedure MGraphics.GetViewport (Var MinX, MinY, MaxX, MaxY : Integer);
{ Return the current viewport }
Begin
MinX:=VMinX;
MinY:=VMinY;
MaxX:=VMaxX;
MaxY:=VMaxY;
End;
Procedure MGraphics.Clear;
{ Clear the current viewport using the current background color }
Var
SaveMode : Byte;
Begin
SaveMode:=WriteMode;
WriteMode:=NormalPut;
Paint (0,0,1+GetMaxX,1+GetMaxY,BgColor);
WriteMode:=SaveMode;
CP.x:=0;
CP.y:=0;
End;
Procedure MGraphics.MoveRel (dx, dy : Integer);
Begin
Inc (CP.x,dx);
Inc (CP.y,dy);
End;
Procedure MGraphics.MoveTo (x, y : Integer);
Begin
CP.x:=x;
CP.y:=y;
End;
Function MGraphics.GetX : Integer; Begin GetX:=CP.x; End;
Function MGraphics.GetY : Integer; Begin GetY:=CP.y; End;
Procedure MGraphics.SetWriteMode (Mode : Byte);
{ Set the current writemode }
Begin
If Mode IN [NormalPut..XorPut] then WriteMode:=Mode;
End;
Procedure MGraphics.SetLogicPalette (From, NumberOf : Integer; Entries : Array Of RGB);
{ Set (part of) a logic palette }
Var
n : Integer;
Begin
For n:=From to From+NumberOf-1 Do SetLogicPalEntry (n,Entries[n-From]);
End;
Procedure MGraphics.GetLogicPalette (From, NumberOf : Integer; Var Entries : Array Of RGB);
{ Return (part of) a logic palette }
Var
n : Integer;
Begin
For n:=From to From+NumberOf-1 Do GetLogicPalEntry (n,Entries[n-From]);
End;
Function MGraphics.CheckClip (Var Scanline, Index, Width, Offset : Integer) : Boolean;
Begin
Offset:=0;
CheckClip:=False;
Inc (Index,VMinX);
Inc (Scanline,VMinY);
If (ScanlineVMaxY) Or (Index>VMaxX) then Exit;
If Index(VMaxX+1) then Width:=1+VMaxX-Index;
CheckClip:=Width>0;
End;
Procedure MGraphics.GetScanlinePattern (y, x, Width : Integer; Var Data);
Var
BitMapX, BitMapY, bx : Integer;
Offset : Word;
ScanlineData : Array [0..0] Of Byte ABSOLUTE Data;
Begin
BitmapY:=y MOD FillPattern^.Height; If BitmapY<0 then BitmapY:=FillPattern^.Height-BitmapY;
Offset:=BitMapY*FillPattern^.Width;
BitmapX:=x MOD FillPattern^.Width; If BitmapX<0 then BitmapX:=FillPattern^.Width+BitmapX;
For bx:=0 to Width-1 Do Begin
ScanlineData[bx]:=FillPattern^.Data[Offset+BitMapX];
Inc (BitMapX); If BitMapX=FillPattern^.Width then BitMapX:=0;
End;
End;
Procedure MGraphics.PushPoint (x, y : Integer);
Begin
If Buffer.WordIndex<(StdBufferSize DIV 2) then Begin
Buffer.Words[Buffer.WordIndex]:=x;
Buffer.Words[Buffer.WordIndex+1]:=y;
Inc (Buffer.WordIndex,2);
End;
End;
Procedure MGraphics.PopPoint (Var x, y : Integer);
Begin
If Buffer.WordIndex>1 then Begin
x:=Buffer.Words[Buffer.WordIndex-2];
y:=Buffer.Words[Buffer.WordIndex-1];
Dec (Buffer.WordIndex,2);
End
Else Begin x:=-1; y:=-1; End;
End;
Constructor MGenericCard.Init (NewGraphicsMode : GraphicsMode; ClearMem : Boolean);
Begin
If Not Inherited Init (NewGraphicsMode) then Fail;
Regs.AH:=$0F;
Intr ($10,Regs);
LastGraphicsMode:=Regs.AL;
If LastGraphicsMode=NewGraphicsMode.Mode then
If ClearMem then Clear Else
Else Begin
Regs.AH:=0;
Regs.AL:=NewGraphicsMode.Mode;
If Not ClearMem then Regs.AL:=Regs.AL Or 128;
Intr ($10,Regs);
End;
End;
Destructor MGenericCard.Done;
Begin
Regs.AH:=$0F;
Intr ($10,Regs);
If LastGraphicsMode<>Regs.AL then Begin
Regs.AH:=0;
Regs.AL:=LastGraphicsMode;
Intr ($10,Regs);
End;
Inherited Done;
End;
Procedure MGenericCard.SetScanline (Scanline, Index, Width : Integer; Var Data);
Var
Bytes : Array [0..0] Of Byte ABSOLUTE Data;
x, Offset : Integer;
Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
For x:=0 to Width-1 Do Begin
Regs.AH:=$0C;
Regs.AL:=Bytes[Offset+x];
If (Graphics_Mode.Mode=$0F) And (Regs.AL And 2>0) then Regs.AL:=4 Or (Regs.AL And 1);
Regs.BH:=0;
Regs.CX:=Index+x;
Regs.DX:=Scanline;
Intr ($10,Regs);
End;
End;
Procedure MGenericCard.GetScanline (Scanline, Index, Width : Integer; Var Data);
Var
Bytes : Array [0..0] Of Byte ABSOLUTE Data;
Offset, x : Integer;
Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
For x:=0 to Width-1 Do Begin
Regs.AH:=$0D;
Regs.BH:=0;
Regs.CX:=Index+x;
Regs.DX:=Scanline;
Intr ($10,Regs);
Bytes[Offset+x]:=Regs.AL;
If Graphics_Mode.Mode=$0F then
If Regs.AL And 4>0 then
Bytes[x]:=2 Or (Regs.AL And 1)
Else
Bytes[x]:=Regs.AL And 1;
End;
End;
Procedure MGenericCard.SetLogicPalEntry (Entry : Word; Color : RGB);
Begin
Port [$03C8]:=Entry;
Port [$03C9]:=Color.r;
Port [$03C9]:=Color.g;
Port [$03C9]:=Color.b;
End;
Procedure MGenericCard.GetLogicPalEntry (Entry : Word; Var Color : RGB);
Begin
Port [$03C7]:=Entry;
Color.r:=Port [$03C9];
Color.g:=Port [$03C9];
Color.b:=Port [$03C9];
End;
Constructor MVGACard.Init (NewGraphicsMode : GraphicsMode; ClearMem : Boolean);
Begin
If Not Inherited Init (NewGraphicsMode,ClearMem) then Fail;
End;
Destructor MVGACard.Done;
Begin
Inherited Done;
End;
Procedure MVGACard.SetScanline (Scanline, Index, Width : Integer; Var Data);
Var
Bytes : Array [0..0] Of Byte ABSOLUTE Data;
Mask : Byte;
Offset, x : Integer;
Sg, Sto : Word;
Begin
Case Graphics_Mode.Mode Of
$11 : Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
Sto:=(Scanline*80)+(Index SHR 3);
Mask:=128 SHR (Index And 7);
For x:=0 to Width-1 Do Begin
If Bytes[Offset+x]=1 then
Mem [SegA000:Sto]:=Mem [SegA000:Sto] Or Mask
Else
Mem [SegA000:Sto]:=Mem [SegA000:Sto] And (Mask Xor 255);
Mask:=Mask SHR 1;
If Mask=0 then Begin Mask:=128; Inc (Sto); End;
End;
End;
$0D,$0E,$10,$12 : Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
Port [$03CE]:=5; Port [$03CF]:=2;
Port [$03CE]:=3; Port [$03CF]:=0;
Mask:=128 SHR (Index And 7);
Sto:=(Graphics_Mode.Width SHR 3)*Scanline+(Index SHR 3);
Port [$03CE]:=8;
For x:=0 to Width-1 Do Begin
Port [$03CF]:=Mask;
Mem [SegA000:Sto]:=(Mem [SegA000:Sto] And 0) Or Bytes[Offset+x];
Mask:=Mask SHR 1;
If Mask=0 then Begin Mask:=128; Inc (Sto); End;
End;
End;
$13 : Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
Move (Bytes[Offset],Mem [SegA000:Scanline*320+Index],Width);
End;
Else
Inherited SetScanline (Scanline,Index,Width,Data);
End;
End;
Procedure MVGACard.GetScanline (Scanline, Index, Width : Integer; Var Data);
Var
Bytes : Array [0..0] Of Byte ABSOLUTE Data;
Mask, b, Bit : Byte;
Offset, x : Integer;
Sg, Sto : Word;
Begin
Case Graphics_Mode.Mode Of
$11 : Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
Sto:=(Scanline*80)+(Index SHR 3);
Mask:=128 SHR (Index And 7);
For x:=0 to Width-1 Do Begin
If Mem [SegA000:Sto] And Mask>0 then Bytes[Offset+x]:=1 Else Bytes[Offset+x]:=0;
Mask:=Mask SHR 1;
If Mask=0 then Begin Mask:=128; Inc (Sto); End;
End;
End;
$0D,$0E,$10,$12 : Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
b:=128 SHR (Index And 7);
Sto:=(Graphics_Mode.Width SHR 3)*Scanline+(Index SHR 3);
For x:=0 to Width-1 Do Begin
Port [$03CE]:=8;
Port [$03CF]:=b;
Bytes[Offset+x]:=0;
For Bit:=0 to 3 Do Begin
Port [$03CE]:=4; Port [$03CF]:=Bit;
If Mem [SegA000:Sto] And b>0 then Bytes[Offset+x]:=Bytes[Offset+x] Or 16;
Bytes[Offset+x]:=Bytes[Offset+x] SHR 1;
End;
b:=b SHR 1;
If b=0 then Begin b:=128; Inc (Sto); End;
End;
End;
$13 : Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
Move (Mem [SegA000:Scanline*320+Index],Bytes[Offset],Width);
End;
Else
Inherited GetScanline (Scanline,Index,Width,Data);
End;
End;
Const
ColorIndices2 : Array [0..1] Of Byte = (0,63);
ColorIndices3 : Array [0..3] Of Byte = (0,8,24,1);
ColorIndices4 : Array [0..3] Of Byte = (0,19,21,23);
ColorIndices16 : Array [0..15] Of Byte = (0,1,2,3,4,5,20,7,56,57,58,59,60,61,62,63);
ColorIndices32 : Array [0..15] Of Byte = (0,1,2,3,4,5,6,7,16,17,18,19,20,21,22,23);
Procedure MVGACard.SetLogicPalEntry (Entry : Word; Color : RGB);
Begin
Case Graphics_Mode.Mode Of
$04,$06,$0D,$0E,$0F,$10,$11,$12 : Begin
If Entry>=(1 SHL ColorDepth) then Exit;
Case Graphics_Mode.Mode Of
$04 : Inherited SetLogicPalEntry (ColorIndices4[Entry],Color);
$06 : Inherited SetLogicPalEntry (ColorIndices2[Entry],Color);
$0D : Inherited SetLogicPalEntry (ColorIndices32[Entry],Color);
$0E : Inherited SetLogicPalEntry (ColorIndices32[Entry],Color);
$0F : Inherited SetLogicPalEntry (ColorIndices3[Entry],Color);
$10 : Inherited SetLogicPalEntry (ColorIndices16[Entry],Color);
$11 : Inherited SetLogicPalEntry (ColorIndices2[Entry],Color);
$12 : Inherited SetLogicPalEntry (ColorIndices16[Entry],Color);
End;
End;
Else Begin
Case Graphics_Mode.ColorDepth Of
2 : Inherited SetLogicPalEntry (ColorIndices2[Entry],Color);
4 : Inherited SetLogicPalEntry (ColorIndices16[Entry],Color);
8 : Inherited SetLogicPalEntry (Entry,Color);
End;
End;
End;
End;
Procedure MVGACard.GetLogicPalEntry (Entry : Word; Var Color : RGB);
Begin
Case Graphics_Mode.Mode Of
$04,$06,$0D,$0E,$0F,$10,$11,$12 : Begin
If Entry>=(1 SHL ColorDepth) then Exit;
Case Graphics_Mode.Mode Of
$04 : Inherited GetLogicPalEntry (ColorIndices4[Entry],Color);
$06 : Inherited GetLogicPalEntry (ColorIndices2[Entry],Color);
$0D : Inherited GetLogicPalEntry (ColorIndices32[Entry],Color);
$0E : Inherited GetLogicPalEntry (ColorIndices32[Entry],Color);
$0F : Inherited GetLogicPalEntry (ColorIndices3[Entry],Color);
$10 : Inherited GetLogicPalEntry (ColorIndices16[Entry],Color);
$11 : Inherited GetLogicPalEntry (ColorIndices2[Entry],Color);
$12 : Inherited GetLogicPalEntry (ColorIndices16[Entry],Color);
End;
End;
Else Begin
Case Graphics_Mode.ColorDepth Of
2 : Inherited GetLogicPalEntry (ColorIndices2[Entry],Color);
4 : Inherited GetLogicPalEntry (ColorIndices16[Entry],Color);
8 : Inherited GetLogicPalEntry (Entry,Color);
End;
End;
End;
End;
Procedure MSuperVGACard.SetScanline (Scanline, Index, Width : Integer; Var Data);
Var
Bytes : Array [0..0] Of Byte ABSOLUTE Data;
l : LongInt;
Sto, h : Word;
b : Byte;
Offset : Integer;
Begin
If Graphics_Mode.Mode<=$13 then { Standard VGA mode }
Inherited SetScanline (Scanline,Index,Width,Data)
Else Begin { Supervga mode }
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
Case Graphics_Mode.ColorDepth Of
4 : Inherited SetScanline (Scanline, Index, Width, Data);
8 : Begin
l:=Scanline; l:=l*Graphics_Mode.Width+Index;
b:=l DIV (Grain SHL 10);
SetBank (b);
Sto:=l MOD (Grain SHL 10);
If Sto<(65536-Graphics_Mode.Width) then
Move (Bytes[Offset],Mem [SegA000:Sto],Width)
Else Begin
h:=1+(Sto Xor 65535);
If h>=Width then h:=Width;
Move (Bytes[Offset],Mem [SegA000:Sto],h);
SetBank (b+1);
Move (Bytes[Offset+h],Mem [SegA000:0],Width-h);
End;
End;
End;
End;
End;
Procedure MSuperVGACard.GetScanline (Scanline, Index, Width : Integer; Var Data);
Var
Bytes : Array [0..0] Of Byte ABSOLUTE Data;
l : LongInt;
Sto, h : Word;
b : Byte;
Offset : Integer;
Begin
If Graphics_Mode.Mode<=$13 then
Inherited GetScanline (Scanline,Index,Width,Data)
Else Begin
If Not CheckClip (Scanline,Index,Width,Offset) then Exit;
Case Graphics_Mode.ColorDepth Of
4 : Inherited GetScanline (Scanline, Index, Width, Data);
8 : Begin
l:=Scanline; l:=l*Graphics_Mode.Width+Index;
b:=l DIV (Grain SHL 10);
SetBank (b);
Sto:=(l MOD (Grain SHL 10));
If Sto<(65536-Graphics_Mode.Width) then
Move (Mem [SegA000:Sto],Bytes[Offset],Width)
Else Begin
h:=1+(Sto Xor 65535);
If h>=Width then h:=Width;
Move (Mem [SegA000:Sto],Bytes[Offset],h);
SetBank (b+1);
Move (Mem [SegA000:0],Bytes[Offset+h],Width-h);
End;
End;
End;
End;
End;
Procedure MSuperVGACard.SetBank (Bank : Word);
Begin
RunError (211);
End;
Function MSuperVGACard.GetBank : Word;
Begin
RunError (211);
End;
Procedure MSuperVGACard.SetGranularity (Granularity : Word);
{ Set memorybank grain. Usually 64 Kb, but may differ! }
Begin
Grain:=Granularity;
End;
Constructor MTsengET4000Card.Init (NewGraphicsMode : GraphicsMode; ClearMem : Boolean);
Begin
SetGranularity (64); { ET4000 has a bank-granularity of 64 Kb }
Inherited Init (NewGraphicsMode,ClearMem)
End;
Procedure MTsengET4000Card.SetBank (Bank : Word);
Begin
Port [$03CD]:=Bank+(Bank SHL 4);
End;
Function MTsengET4000Card.GetBank : Word;
Begin
GetBank:=Port [$03CD] And 15;
End;
{$IFNDEF DPMI}
Constructor MVesaCard.Init (NewGraphicsMode : GraphicsMode; ClearMem : Boolean);
Begin
If NewGraphicsMode.Mode<$100 then { Not a vesa mode, redirect to standard vgacard }
Inherited Init (NewGraphicsMode,ClearMem)
Else Begin
MGraphics.Init (NewGraphicsMode);
Regs.AX:=$4F03;
Intr ($10,Regs);
If VesaError then Exit;
LastGraphicsMode:=Regs.BX;
Regs.AX:=$4F01;
Regs.CX:=NewGraphicsMode.Mode;
Regs.ES:=Seg (VesaInfo);
Regs.DI:=Ofs (VesaInfo);
Intr ($10,Regs);
If VesaError then Exit;
Regs.AX:=$4F02;
Regs.BX:=NewGraphicsMode.Mode;
If Not ClearMem then Regs.BX:=Regs.BX Or 32768;
Intr ($10,Regs);
If VesaError then Exit;
SetGranularity (VesaInfo.WinGrain);
End;
End;
Destructor MVesaCard.Done;
Begin
Regs.AX:=$4F02;
Regs.BX:=LastGraphicsMode;
Intr ($10,Regs);
End;
Procedure MVesaCard.SetBank (Bank : Word);
Begin
Regs.AX:=$4F05;
Regs.BH:=0;
Regs.DX:=Bank;
Regs.BL:=0;
Intr ($10,Regs);
Regs.AX:=$4F05;
Regs.BH:=0;
Regs.DX:=Bank;
Regs.BL:=1;
Intr ($10,Regs);
VesaError;
End;
Function MVesaCard.GetBank : Word;
Begin
Regs.AX:=$4F05;
Regs.BH:=1;
Regs.BL:=0;
Intr ($10,Regs);
GetBank:=Regs.DX;
VesaError;
End;
Function MVesaCard.VesaError : Boolean;
Begin
VesaError:=(Regs.AL<>$4F) Or (Regs.AH=1);
End;
{$ENDIF}
End.
(
geocities.com/~franzglaser)