Добавил:
bagiwow
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз:
Предмет:
Файл:
(***********************************************)
(* *)
(* Graph Unit Demo *)
(* Copyright (c) 1999 by TMT Development Corp. *)
(* Author: Vadim Bodrov, TMT Development Corp. *)
(* *)
(* Targets: *)
(* MS-DOS 32-bit protected mode *)
(* Win32 Console *)
(***********************************************)
{$ifndef __CON__}
This program must be compiled as MS-DOS or Win32 console application
{$endif}
uses Graph, ZenTimer, CRT;
const
LineStyles : array[0..4] of string[9] =
('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
var MaxX,MaxY: DWord;
VST,HST: Boolean:=false;
GraphMode: Word:=0;
function LongToStr (L: LongInt): String;
var S: String;
begin
Str(L,S);
LongToStr:= S;
end;
function RConv(R: LongInt): String;
begin
RConv:=LongToStr(R div 10)+'.'+LongToStr(R mod 10);
end;
function AddSpace (D: DWord): String;
var S: String;
begin
S:=LongToStr(D);
if Length(S)=3 then Result:=' '+S else Result:=S;
end;
function DWordToHex (D: DWord): String;
const HexTable: array [0..15] of Char=('0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F');
var HexStr: String:='00000000';
i: DWord;
s: DWord:=24;
begin
s:=24;
for i:=0 to 3 do begin
HexStr[i*2+1]:=HexTable[(D shr s) and $F0 div 16];
HexStr[i*2+2]:=HexTable[(D shr s) and $0F];
Dec(s,8);
end;
Result:=HexStr;
end;
function GetChar (D: DWord): Char;
begin
if D<10 then
Result:=Char(D+DWord('0'))
else
Result:=Char(D+55);
end;
function GetByte (C: Char): Byte;
begin
if C<'0' then begin
Result:=0;
exit;
end;
if C<'A' then
Result:=Byte(C)-Byte('0')
else
Result:=Byte(C)-55;
end;
procedure MainFrame;
begin
ClrScr;
Writeln;
Writeln;
Writeln;
{$ifdef __DOS__}
Write(' VBE OEM string : ');
if GetOemString<>'' then
Writeln(GetOemString)
else
Writeln('Unknown');
if GetVbeVersion>0 then begin
Write(' VBE version : '+LongToStr(Hi(GetVbeVersion))+'.'+
LongToStr(Lo(GetVbeVersion)));
Writeln(' with '+LongToStr(TotalVbeMemory div 1024)+' Kb memory');
if GetVbeVersion>=$200 then begin
Writeln(' OEM vendor name : '+GetOemVendorName);
Writeln(' OEM product name : '+GetOemProductName);
Writeln(' OEM product revision : '+GetOemProductRev);
if GetLfbAddress<>0 then
Writeln(' LFB located at : $'+DWordToHex(GetLfbAddress));
end else begin
Writeln;
Writeln(' Hint: Use UniVBE v5.1 or higher by SciTech Soft to gain access to');
Writeln(' additional video modes and linear framebuffer.');
end;
end;
Writeln;
{$endif}
end;
procedure TextBorder (Header: String);
var i: DWord;
begin
GotoXY(Lo(WindMax) div 2 - Length(Header) div 2,1);
Writeln(Header);
for i:=2 to Lo(WindMax)-1 do begin
GotoXY(i,2); Write('Д');
GotoXY(i,Hi(WindMax)); Write('Д');
end;
GotoXY(1,2); Write('Ъ');
GotoXY(Lo(WindMax),2); Write('ї');
GotoXY(1,Hi(WindMax)); Write('А');
GotoXY(Lo(WindMax),Hi(WindMax)); Write('Щ');
for i:=3 to Hi(WindMax)-1 do begin
GotoXY(1,i); Write('і');
GotoXY(Lo(WindMax),i); Write('і');
end;
end;
function ModeSelect: DWord;
var ModesList: array [0..70] of GraphModeType;
Modes: array [0..70] of Word;
Ch: Char;
Bpp,i,MaxMode: DWord;
begin
GetVbeModesList(ModesList);
repeat
repeat
HideCursor;
TextColor(White);
MainFrame;
Writeln(' [0] - MCGA/VGA (13h BIOS) mode');
Writeln(' [1] - SVGA 08 bits per pixel modes');
Writeln(' [2] - SVGA 15 bits per pixel modes');
Writeln(' [3] - SVGA 16 bits per pixel modes');
Writeln(' [4] - SVGA 24 bits per pixel modes');
Writeln(' [5] - SVGA 32 bits per pixel modes');
Writeln;
Writeln(' [Esc] - exit');
Writeln;
{$ifdef __DOS__}
Write(' Demo options: [H]orizontal scrolling test : ');
TextColor(LightGray);
if HST then Writeln('Yes') else Writeln ('No ');
TextColor(White);
Write(' [V]ertical scrolling test : ');
TextColor(LightGray);
if VST then Writeln('Yes') else Writeln ('No ');
Writeln;
{$endif}
TextColor(White);
TextBorder('Graph unit demo program by TMT Corp., 1998');
repeat
Ch:=ReadKey;
Ch:=UpCase(Ch)
until ((Ch>='0') and (Ch<'6')) or (Ch='V') or (Ch='H') or (Ch=#27);
if Ch='V' then VST:=not VST;
if Ch='H' then HST:=not HST;
until (Ch<>'V') and (Ch<>'H');
if Ch=#27 then begin
ShowCursor;
NormVideo;
ClrScr;
Writeln(' GRDEMO terminated.');
Halt(0);
end;
case Ch of
'0': begin
Result:=$13;
exit;
end;
'1': Bpp:=8;
'2': Bpp:=15;
'3': Bpp:=16;
'4': Bpp:=24;
'5': Bpp:=32;
end;
ClrScr;
Writeln;
Writeln;
MaxMode:=1;
Writeln;
for i:=0 to TotalVbeModes do begin
if (ModesList[i].BitsPerPixel=Bpp) and (ModesList[i].VideoMode <> $FFFF) then
begin
Modes[MaxMode]:=i;
Write(' [',GetChar(MaxMode),'] - ',AddSpace(ModesList[i].XResolution),
' x ',AddSpace(ModesList[i].YResolution),' ',AddSpace(ModesList[i].VideoMode));
if ModesList[i].HaveLFB then
Writeln(' (Banked and Linear)')
else
Writeln(' (Banked Only)');
inc(MaxMode);
end;
end;
if MaxMode=1 then Writeln(' Those modes are not supported');
Writeln;
Writeln(' [Esc] - return to main menu');
TextBorder('Select mode resolution to test');
repeat
if Ch<>#27 then Ch:=UpCase(Readkey);
until ((GetByte(Ch)>=1) and (GetByte(Ch)<MaxMode)) or (Ch=#27);
until GetByte(Ch)>0;
Result:=ModesList[Modes[GetByte(Ch)]].VideoMode;
{$ifndef __WIN32__}
if ModesList[Modes[GetByte(Ch)]].HaveLfb then
begin
ClrScr;
Writeln;
Writeln;
Writeln;
Writeln(' [0] - Banked framebuffer mode');
Writeln(' [1] - Linear framebuffer mode');
TextBorder('Choose framebuffer mode');
repeat
Ch:=ReadKey;
until (Ch>='0') and (Ch<='1');
if Ch='1' then Result+$4000;
end;
{$endif}
end;
procedure SetDefaults;
begin
MaxX:=GetMaxX;
MaxY:=GetMaxY;
SetColor(clWhite);
SetLineStyle(SolidLn,0,NormWidth);
SetTextJustify(LeftText,TopText);
end;
procedure DrawBorder;
var
ViewPort : ViewPortType;
begin
SetLineStyle(SolidLn,0,NormWidth);
GetViewSettings(ViewPort);
with ViewPort do Rectangle(0,0,X2-X1,Y2-Y1);
end;
procedure FullPort;
begin
SetViewPort(0,0,MaxX,MaxY,ClipOn);
end;
procedure MainWindow (Header: String);
begin
SetDefaults;
ClearDevice;
SetTextStyle(DefaultFont, HorizDir);
SetTextJustify(CenterText, TopText);
FullPort;
OutTextXY(MaxX div 2,2,Header);
SetViewPort(0,TextHeight('M')+4,MaxX,MaxY-(TextHeight('M')+4),ClipOn);
DrawBorder;
SetViewPort(1,TextHeight('M')+5,MaxX-1,MaxY-(TextHeight('M')+5),ClipOn);
end;
procedure GetMode (var ModeStr: String);
begin
if GraphMode=$13 then ModeStr:='MCGA/VGA' else begin
case GetBitsPerPixel of
8: ModeStr:='SVGA (8 bpp)';
15: ModeStr:='SVGA (15 bpp)';
16: ModeStr:='SVGA (16 bpp)';
24: ModeStr:='SVGA (24 bpp)';
32: ModeStr:='SVGA (32 bpp)';
end;
end;
end;
procedure StatusLine(Msg: String);
begin
FullPort;
SetTextStyle(DefaultFont,HorizDir);
SetTextJustify(CenterText,TopText);
SetLineStyle(SolidLn,0,NormWidth);
SetFillStyle(SolidFill,clBlack);
Bar(0,MaxY-(TextHeight('M')+4),MaxX,MaxY);
Rectangle(0,MaxY-(TextHeight('M')+4), MaxX, MaxY);
OutTextXY(MaxX div 2,MaxY-(TextHeight('M')+2), Msg);
SetViewPort(1,TextHeight('M')+5,MaxX-1,MaxY-(TextHeight('M')+5),ClipOn);
end;
function WaitAKey: Boolean;
var
Ch : char;
begin
repeat until KeyPressed;
Ch:=ReadKey;
if Ch=#0 then Ch:=ReadKey;
Result:=Ch=#27;
ClearDevice;
end;
procedure ReportStatus;
const X = 10;
var ViewInfo : ViewPortType;
LineInfo : LineSettingsType;
TextInfo : TextSettingsType;
Palette : PaletteType;
ModeStr : String;
Y : DWord;
procedure WriteOut(S : string);
begin
OutTextXY(X,Y,S);
Inc(Y,TextHeight('M')+2);
end;
begin
GetMode(ModeStr);
GetViewSettings(ViewInfo);
GetLineSettings(LineInfo);
GetTextSettings(TextInfo);
GetPalette(Palette);
Y:=4;
MainWindow('Status report after SetGraphMode');
SetTextJustify(LeftText, TopText);
WriteOut('Graphics mode : '+ModeStr);
WriteOut('Screen resolution : (0, 0, '+LongToStr(GetMaxX)+', '+LongToStr(GetMaxY)+')');
if isLfbUsed then
WriteOut('LFB : Enabled')
else
WriteOut('LFB : Disabled');
with ViewInfo do
begin
WriteOut('Current view port : ('+LongToStr(x1)+', '+LongToStr(y1)+', '+LongToStr(x2)+', '+LongToStr(y2)+')');
if ClipOn then
WriteOut('Clipping : ON')
else
WriteOut('Clipping : OFF');
end;
WriteOut('Max pages : '+LongToStr(GetMaxPage+1));
if GetMaxColor <= 255 then
WriteOut('Palette entries : '+LongToStr(Palette.Size));
WriteOut('Max Color : '+LongToStr(GetMaxColor));
WriteOut('Current color : '+LongToStr(GetColor));
with LineInfo do
begin
WriteOut('Line style : '+LineStyles[LineStyle]);
WriteOut('Line thickness : '+LongToStr(Thickness));
end;
if WaitAKey then exit;
end;
function RandColor : DWord;
begin
Result:=Random($FFFF)+DWord(Random($FFFF)) shl 16;
case GetBitsPerPixel of
8: Result:=Result and $FF;
15,16: Result:=Result and $FFFF;
24,32: Result:=Result and $FFFFFF;
end;
end;
procedure CircleDemo;
var MaxRadius: DWord;
begin
MainWindow('Circle demonstration');
StatusLine('Esc aborts or press a key');
MaxRadius:=MaxY div 10;
repeat
SetColor(RandColor);
Circle(Random(MaxX),Random(MaxY),Random(MaxRadius));
until KeyPressed;
end;
procedure FillEllipseDemo;
var FillColor,MaxRadius: DWord;
begin
MainWindow('FillEllipse demonstration');
StatusLine('Esc aborts or press a key');
MaxRadius:=MaxY div 10;
repeat
FillColor:=RandColor;
SetColor(not FillColor);
SetFillStyle(Random(12),FillColor);
FillEllipse(Random(MaxX),Random(MaxY),Random(MaxRadius),Random(MaxRadius));
until KeyPressed;
end;
procedure RandBarDemo;
var MaxWidth: DWord;
MaxHeight: DWord;
ViewInfo: ViewPortType;
Color: DWord;
begin
MainWindow('Random Bars');
StatusLine('Esc aborts or press a key');
GetViewSettings(ViewInfo);
with ViewInfo do begin
MaxWidth:=X2-X1;
MaxHeight:=Y2-Y1;
end;
repeat
Color:=RandColor;
SetColor(Color);
SetFillStyle(Random(12), not Color);
Bar3D(Random(MaxWidth),Random(MaxHeight),Random(MaxWidth),Random(MaxHeight),0,TopOff);
until KeyPressed;
end;
procedure PutImageDemo;
var R: DWord:=20;
CurPort : ViewPortType;
StartX,StartY: LongInt;
XDir,YDir: LongInt;
procedure MoveSaucer (var X, Y: LongInt; Width, Height: DWord);
begin
inc(X,XDir);
inc(Y,YDir);
if Random(100)>95 then XDir:=XDir+1;
if Random(100)>95 then YDir:=YDir+1;
if Random(100)>95 then XDir:=XDir-1;
if Random(100)>95 then YDir:=YDir-1;
with CurPort do begin
if X1+X > X2 then
XDir:=-Random(5)-1
else
if X<-2*R then XDir:=Random(5)+1;
if Y1+Y > Y2 then YDir:=-Random(5)-1
else
if Y<-R then YDir:=Random(5)+1;
end;
end;
var
Asp : Real;
Saucer : Pointer;
BackGndr : Pointer;
X, Y : LongInt;
ulx, uly : DWord;
lrx, lry : DWord;
sx,sy : DWord;
Size : DWord;
i : Dword;
begin
GetAspectRatio(Asp);
FullPort;
XDir:=Random(5)+1;
YDir:=Random(5)+1;
StartX:=MaxX div 2;
StartY:=MaxY div 2;
MainWindow('GetImage / Transparent PutImage Demo');
StatusLine('Esc aborts or press a key...');
GetViewSettings(CurPort);
DrawEllipse(StartX,StartY,R,(R div 3)+2);
DrawEllipse(StartX,StartY-4,R,R div 3);
Line(StartX+7,StartY-6,StartX+10,StartY-12);
Circle(StartX+10,StartY-12,2);
Line(StartX-7,StartY-6,StartX-10,StartY-12);
Circle(StartX-10,StartY-12,2);
SetFillStyle(SolidFill,clWhite);
FloodFill(StartX+1,StartY+4,GetColor);
SetFillStyle(SolidFill,clRed);
ExpandFill(StartX+1,StartY-4);
ulx:=StartX-(R+1);
uly:=StartY-14;
lrx:=StartX+(R+1);
lry:=StartY+(R*2);
sx:=lrx-ulx+1;
sy:=lry-uly+1;
Size:=ImageSize(ulx,uly,ulx+SX,uly+SY);
GetMem(Saucer,Size);
if Saucer=nil then exit;
GetMem(BackGndr,Size);
if BackGndr=nil then begin
FreeMem(Saucer,Size);
exit;
end;
GetImage(ulx,uly,ulx+SX,uly+sy,Saucer^);
{ Plot some "stars" }
for i:=1 to 1000 do PutPixel(Random(MaxX),Random(MaxY),RandColor);
SetFillStyle(SolidFill,clBlue);
X:=MaxX div 2;
Y:=MaxY div 2;
{ Dwar planet }
SetFillStyle(SolidFill,clLightBlue);
FillCircle(StartX,StartY,Round(MaxY div 4 /Asp));
{ Move the saucer around }
repeat
GetImage(X,Y,X+SX,Y+SY,BackGndr^);
SetTranspMode(True,clBlack);
PutImage(X,Y,Saucer^); -- draw image
Delay(20); Retrace;
SetTranspMode(False,0);
PutImage(X,Y,BackGndr^); -- restore background
MoveSaucer(X,Y,lrx-ulx+1,lry-uly+1); -- width/height
until KeyPressed;
SetTranspMode(False,0);
FreeMem(Saucer,Size);
FreeMem(BackGndr,Size);
end;
procedure AspectRatioDemo;
var ViewInfo: ViewPortType;
CenterX: LongInt;
CenterY: LongInt;
Radius: DWord;
i: LongInt;
AspInc,Asp,A: Real;
RadiusStep: DWord;
begin
MainWindow('Aspect Ratio demonstration');
GetViewSettings(ViewInfo);
GetAspectRatio(Asp);
with ViewInfo do begin
CenterX:=(x2-x1) div 2;
CenterY:=(y2-y1) div 2;
Radius:=Round((y2-y1)/Asp/2);
end;
RadiusStep:=(Radius div 30);
Circle(CenterX,CenterY,Radius);
AspInc:=Asp/30;
A:=Asp;
for i:=1 to 30 do begin
A:=A-AspInc;
SetAspectRatio(A);
Circle(CenterX,CenterY,Radius);
Dec(Radius,RadiusStep);
end;
Inc(Radius,RadiusStep*30);
A:=Asp;
for i:=1 to 30 do begin
A:=A+AspInc;
SetAspectRatio(A);
if Radius>RadiusStep then Dec(Radius,RadiusStep);
Circle(CenterX,CenterY,Radius);
end;
SetAspectRatio(Asp);
end;
procedure FillTriangleDemo;
const MaxPts= 4;
var Color: DWord;
begin
MainWindow('FillTriangle demonstration');
StatusLine('Esc aborts or press a key...');
repeat
Color:=RandColor;
SetFillStyle(Random(12), Color);
SetColor(not Color);
FillTriangle(Random(MaxX),Random(MaxY),Random(MaxX),Random(MaxY),
Random(MaxX),Random(MaxY));
until KeyPressed;
end;
procedure BarDemo;
const
NumBars = 7;
BarHeight : array[1..NumBars] of DWord = (1, 3, 5, 2, 4, 3, 1);
var
ViewInfo : ViewPortType;
BarNum : DWord;
H : DWord;
XStep : Real;
YStep : Real;
i,j : LongInt;
Color : DWord;
begin
MainWindow('Bar / Rectangle demonstration');
H:=3*TextHeight('M');
GetViewSettings(ViewInfo);
SetTextJustify(CenterText,TopText);
SetTextStyle(DefaultFont,HorizDir);
OutTextXY(MaxX div 2,6,'These are 2D bars');
SetTextStyle(DefaultFont,HorizDir);
with ViewInfo do
SetViewPort(x1+50,y1+30,x2-50,y2-10,ClipOn);
GetViewSettings(ViewInfo);
with ViewInfo do begin
Line(H,H,H,(y2-y1)-H);
Line(H,(y2-y1)-H,(x2-x1)-H,(y2-y1)-H);
YStep:=((y2-y1)-(2*H))/NumBars;
XStep:=((x2-x1)-(2*H))/NumBars;
J:=(y2-y1)-H;
SetTextJustify(LeftText,CenterText);
for i:=0 to NumBars do
begin
Line(H div 2,j,H,j);
OutTextXY(0,j,LongToStr(i));
J:=Round(j-Ystep);
end;
j:=H;
SetTextJustify(CenterText,TopText);
for i:=1 to Succ(NumBars) do begin
SetColor(clWhite);
Line(j,(y2-y1)-H,j,(y2-y1-3)-(H div 2));
OutTextXY(j,(y2-y1)-(H div 2),LongToStr(i));
if i<>Succ(NumBars) then begin
SetFillColor(RandColor);
Bar(j,Round((y2-y1-H)-(BarHeight[i]*Ystep)),Round(j+Xstep),(y2-y1)-H-1);
Rectangle(j,Round((y2-y1-H)-(BarHeight[i]*Ystep)),Round(j+Xstep),(y2-y1)-H-1);
end;
j:=Round(j+Xstep);
end;
end;
end;
procedure Bar3DDemo;
const
NumBars = 9;
BarHeight : array[1..NumBars] of DWord = (1, 3, 2, 5, 4, 2, 1, 2, 5);
YTicks = 5;
var
ViewInfo : ViewPortType;
H : DWord;
XStep : Real;
YStep : Real;
i,j : LongInt;
Depth : DWord;
Color : DWord;
begin
MainWindow('Bar3D / Rectangle demonstration');
H:=3*TextHeight('M');
GetViewSettings(ViewInfo);
SetTextJustify(CenterText,TopText);
SetTextStyle(DefaultFont,HorizDir);
OutTextXY(MaxX div 2,6,'These are 3D bars');
SetTextStyle(DefaultFont,HorizDir);
with ViewInfo do SetViewPort(x1+50,y1+40,x2-50,y2-10,ClipOn);
GetViewSettings(ViewInfo);
with ViewInfo do begin
Line(H,H,H,(y2-y1)-H);
Line(H,(y2-y1)-H,(x2-x1)-H,(y2-y1)-H);
YStep:=((y2-y1)-(2*H))/YTicks;
XStep:=((x2-x1)-(2*H))/NumBars;
j:=(y2-y1)-H;
SetTextJustify(LeftText,CenterText);
for i:=0 to Yticks do begin
Line(H div 2,j,H,j);
OutTextXY(0,j,LongToStr(i));
j:=Round(j-Ystep);
end;
Depth:=Trunc(0.25*XStep);
SetTextJustify(CenterText,TopText);
j:=H;
for i:=1 to Succ(NumBars) do begin
SetColor(clWhite);
Line(j,(y2-y1)-H,j,(y2-y1-3)-(H div 2));
OutTextXY(j,(y2-y1)-(H div 2),LongToStr(i-1));
if i<>Succ(NumBars) then begin
SetFillStyle(i, RandColor);
Bar3D(j,Round((y2-y1-H)-(BarHeight[i]*Ystep)),
Round(j+Xstep-Depth),Round((y2-y1)-H-1),Depth,TopOn);
j:=Round(j+Xstep);
end;
end;
end;
end;
procedure LineStyleDemo;
var Style : Word;
Step : DWord;
X,Y : DWord;
ViewInfo : ViewPortType;
begin
ClearDevice;
SetDefaults;
MainWindow('Pre-defined line styles');
GetViewSettings(ViewInfo);
with ViewInfo do begin
X:=35;
Y:=10;
Step:=(x2-x1) div 11;
SetTextJustify(LeftText,TopText);
OutTextXY(X,Y,'NormWidth');
SetTextJustify(CenterText,TopText);
for Style:=0 to 3 do begin
SetLineStyle(Style,0,NormWidth);
Line(X,Y+20,X,Y2-40);
OutTextXY(X,Y2-35,LongToStr(Style));
Inc(X,Step);
end;
Inc(X,2*Step);
SetTextJustify(LeftText,TopText);
OutTextXY(X,Y,'ThickWidth');
SetTextJustify(CenterText,TopText);
for Style:=0 to 3 do begin
SetLineStyle(Style,0,ThickWidth);
Line(X,Y+20,X,Y2-40);
OutTextXY(X,Y2-35,LongToStr(Style));
Inc(X,Step);
end;
end;
SetTextJustify(LeftText,TopText);
end;
procedure UserLineStyleDemo;
var Style : Word:=0;
X,Y : DWord;
i : Word:=0;
ViewInfo : ViewPortType;
begin
MainWindow('User defined line styles');
GetViewSettings(ViewInfo);
with ViewInfo do begin
X:=4;
Y:=10;
while X<X2-4 do begin
Style:=Style or (1 shl (i mod 16));
SetLineStyle(UserBitLn,Style,NormWidth);
Line(X,Y,X,(y2-y1)-Y);
Inc(X,5);
Inc(i);
if Style=$FFFF then begin
i:=0;
Style:=0;
end;
end;
end;
end;
procedure CrtModeDemo;
var ViewInfo : ViewPortType;
Ch : Char;
begin
MainWindow('SetGraphMode / RestoreCrtMode demo');
GetViewSettings(ViewInfo);
SetTextJustify(CenterText, CenterText);
with ViewInfo do begin
OutTextXY((x2-x1) div 2,(y2-y1) div 2,'Now you are in graphics mode');
StatusLine('Press any key for text mode...');
repeat until KeyPressed;
Ch:=ReadKey;
if Ch=#0 then Ch:=Readkey;
RestoreCrtMode;
ClrScr;
Writeln;
Writeln;
Writeln(' Now you are in text mode');
Writeln(' Press any key to go back to graphics...');
TextBorder('SetGraphMode / RestoreCrtMode demo');
repeat until KeyPressed;
Ch:=ReadKey;
if Ch=#0 then Ch:=Readkey;
SetGraphMode(GraphMode);
MainWindow('SetGraphMode / RestoreCrtMode demo');
SetTextJustify(CenterText,CenterText);
OutTextXY((x2-x1) div 2,(y2-y1) div 2,'Back in graphics mode...');
end;
end;
procedure PolyDemo;
const MaxPts= 4;
var Poly: array[1..MaxPts] of PointType;
i,Color: DWord;
begin
MainWindow('FillPoly demonstration');
StatusLine('Esc aborts or press a key...');
repeat
Color:=RandColor;
SetFillStyle(Random(12),Color);
SetColor(Color);
for i:=1 to MaxPts do
with Poly[I] do begin
X:=Random(MaxX);
Y:=Random(MaxY);
end;
FillPoly(MaxPts,Poly);
until KeyPressed;
end;
procedure LineToDemo;
const MaxPoints= 15;
var
Points : array[0..MaxPoints] of PointType;
ViewInfo : ViewPortType;
Asp : Real;
i,j : LongInt;
CenterX : LongInt;
CenterY : LongInt;
Radius : DWord;
StepAngle : DWord;
Xasp,Yasp : DWord;
Radians : Real;
begin
MainWindow('MoveTo, LineTo demonstration');
GetAspectRatio(Asp);
GetViewSettings(ViewInfo);
with ViewInfo do begin
CenterX:=(x2-x1) div 2;
CenterY:=(y2-y1) div 2;
Radius:=Round((y2-y1) div 3 / Asp);
while Round(CenterY+Asp*(Radius))<(y2-y1)-20 do Inc(Radius);
end;
StepAngle:=360 div MaxPoints;
for i:=0 to MaxPoints-1 do begin
Radians:=(StepAngle*i)*Pi/180;
Points[I].X:=CenterX+Round(Cos(Radians)*Radius);
Points[I].Y:=CenterY-Round(Asp*(Sin(Radians)*Radius));
end;
Circle(CenterX,CenterY,Radius);
for j:=0 to MaxPoints-1 do begin
for i:=j to MaxPoints-1 do begin
MoveTo(Points[I].X,Points[I].Y);
LineTo(Points[J].X,Points[J].Y);
end;
end;
end;
procedure DrawPattern;
var i: DWord;
Value: Byte;
ViewInfo: ViewPortType;
Height: DWord;
begin
GetViewSettings(ViewInfo);
Height:=ViewInfo.Y2-ViewInfo.Y1;
if GetBitsPerPixel>8 then begin
for i:=0 to ViewInfo.X2 do begin
SetColor(RGBColor(i*255 div ViewInfo.X2,0,0));
Line(ViewInfo.X2 shr 1,Height shr 1,i,0);
SetColor(RGBColor(0,i*255 div ViewInfo.X2,0));
Line(ViewInfo.X2 shr 1,Height shr 1,i,Height);
end;
for i:=0 to Height do begin
value:=Byte(i*255 div Height);
SetColor(RGBColor(value,0,255-value));
Line(ViewInfo.X2 shr 1,Height shr 1,0,i);
SetColor(RGBColor(0,255-value,value));
Line(ViewInfo.X2 shr 1,Height shr 1,ViewInfo.X2,i);
end;
end else begin
i:=0;
repeat
SetColor(i mod 255);
Line(ViewInfo.X2 shr 1,Height shr 1,i,0);
SetColor((i+1) mod 255);
Line(ViewInfo.X2 shr 1,Height shr 1,i,Height);
inc(i,4);
until (i>ViewInfo.X2);
i:=0;
repeat
SetColor((i+2) mod 255);
Line(ViewInfo.X2 shr 1,Height shr 1,0,i);
SetColor((i+3) mod 255);
Line(ViewInfo.X2 shr 1,Height shr 1,ViewInfo.X2,i);
inc(i,4);
until (i>Height);
end;
end;
procedure ColorDemo;
begin
MainWindow('Color demonstration');
DrawPattern;
end;
procedure ScrollTest;
var MY,MX,i: Word;
begin
{$ifdef __DOS__}
if VST then begin
ClearDevice;
SetScreenStart(10,0,false);
if GraphResult<>grOk then exit;
SetScreenStart(0,0,false);
MY:=MaxY;
MX:=MaxX;
i:=TotalVbeMemory div (GetScreenHeight+1) div ((GetBitsPerPixel+1) div 8);
repeat
SetLogicalPage(i,my);
GetLogicalPage(mx,my);
dec(i);
until (mx>GetScreenWidth) or (i<GetScreenWidth);
if (GetScreenWidth<mx) and (GetScreenWidth<i) then begin
MainWindow('Horizontal scrolling demo');
StatusLine('Esc aborts or press a key...');
DrawPattern;
ReadKey;
for i:=0 to (MX-GetScreenWidth) do begin
SetScreenStart(i,0,false);
Delay(1);
if KeyPressed then exit;
end;
ReadKey;
for i:=(MX-GetScreenWidth) downto 0 do begin
SetScreenStart(i,0,false);
Delay(1);
if KeyPressed then exit;
end;
end;
ReadKey;
end;
if HST then begin
ClearDevice;
if GraphResult<>grOk then exit;
SetScreenStart(0,0,false);
my:=TotalVbeMemory div GetScreenWidth div ((GetBitsPerPixel+1) div 8);
SetLogicalPage(GetScreenWidth,my);
GetLogicalPage(mx,my);
if GetScreenHeight<my then begin
MainWindow('Vertical scrolling demo');
StatusLine('Esc aborts or press a key...');
DrawPattern;
ReadKey;
for i:=0 to (MY-GetScreenHeight) do begin
SetScreenStart(0,i,false);
Delay(2);
if KeyPressed then exit;
end;
ReadKey;
for i:=(MY-GetScreenHeight) downto 0 do begin
SetScreenStart(0,i,false);
Delay(2);
if KeyPressed then exit;
end;
end;
end;
{$endif}
end;
procedure PaletteDemo;
var Pal,DPal: PaletteType;
i,j: DWord;
begin
MainWindow('Palette demonstartion');
StatusLine('Esc aborts or press a key...');
DrawPattern;
ReadKey;
GetPalette(DPal);
GetPalette(Pal);
for j:=0 to 63 do begin
for i:=0 to 256 do begin
if RGBType(Pal.Colors[i]).Red>0 then Dec(RGBType(Pal.Colors[i]).Red);
if RGBType(Pal.Colors[i]).Green>0 then Dec(RGBType(Pal.Colors[i]).Green);
if RGBType(Pal.Colors[i]).Blue>0 then Dec(RGBType(Pal.Colors[i]).Blue);
end;
if KeyPressed then begin
SetAllPalette(DPal);
exit;
end;
Retrace;
Retrace;
SetAllPalette(Pal);
end;
Delay(100);
for j:=0 to 63 do begin
for i:=0 to 256 do begin
if RGBType(Pal.Colors[i]).Red<RGBType(DPal.Colors[i]).Red
then Inc(RGBType(Pal.Colors[i]).Red);
if RGBType(Pal.Colors[i]).Green<RGBType(DPal.Colors[i]).Green
then Inc(RGBType(Pal.Colors[i]).Green);
if RGBType(Pal.Colors[i]).Blue<RGBType(DPal.Colors[i]).Blue
then Inc(RGBType(Pal.Colors[i]).Blue);
end;
if KeyPressed then begin
SetAllPalette(DPal);
exit;
end;
Retrace;
Retrace;
SetAllPalette(Pal);
end;
end;
function FlipDemo: Boolean;
var i,j,iStep,jStep,APage,Vpage: LongInt;
fpsRate,midRate: LongInt;
lastCount,newCount: LongInt;
S1,S2,S3: String;
begin
fpsRate:=0;
if GetMaxPage>0 then begin
VPage:=0;
APage:=1;
SetActivePage(APage);
SetVisualPage(VPage,true);
SetDefaults;
FullPort;
i:=0;
j:=MaxX;
iStep:=2;
jStep:=-2;
S3:='0';
Str(GetMaxPage+1,S2);
LastCount:=0;
midRate:=0;
LZTimerOn;
repeat
SetActivePage(APage);
ClearPage;
OutTextXY(10,10,'Pages flipping');
OutTextXY(10,26,'FPS rate '+RConv(fpsRate)+' FPS, Page '+
LongToStr(APage+1)+' of '+S2);
Line(i,0,MaxX-i,MaxY);
Line(0,MaxY-j,MaxX,j);
Rectangle(0,0,GetMaxX,GetMaxY);
VPage:=(VPage+1) mod (GetMaxPage+1);
SetVisualPage(VPage,true);
if APage=0 then begin
newCount:=LZTimerLap;
fpsRate:=Word(10000000 div (newCount-lastCount))*(GetMaxPage+1);
if midRate=0 then
midRate:=fpsRate
else midRate:=(midRate+fpsRate) shr 1;
lastCount:=newCount;
end;
APage:=(APage+1) mod (GetMaxPage+1);
inc(i,iStep);
if i>MaxX then begin
i:=MaxX-2;
iStep:=-2;
end;
if i<0 then begin
i:=2;
iStep:=2;
end;
inc(j,jStep);
if j>MaxY then begin
j:=MaxY-2;
jStep:=-2;
end;
if j<0 then begin
j:=2;
jStep:=2;
end;
until (KeyPressed);
LZTimerOff;
SetActivePage(0);
SetVisualPage(0,true);
Result:=true;
end else Result:=false;
end;
procedure XorDemo;
var r,s,i: DWord;
Asp: Real;
begin
MainWindow('XorPut demonstartion');
StatusLine('Esc aborts or press a key...');
SetWriteMode(XorPut);
GetAspectRatio(Asp);
r:=(Round(GetMaxY/Asp) div 2)-32;
repeat
i:=0;
s:=r div 15;
repeat
Circle(MaxX div 2,MaxY div 2 - 16,i);
Retrace;
Circle(MaxX div 2,MaxY div 2 - 16,(r-i));
Retrace;
inc(i,s);
until i>=r;
until KeyPressed;
SetWriteMode(NormalPut);
end;
procedure DoTest;
begin
ReportStatus;
if GetBitsPerPixel>8 then
ColorDemo
else
PaletteDemo;
if WaitAKey then exit;
if (VST) or (HST) then begin
ScrollTest;
if WaitAKey then exit;
SetGraphMode(GraphMode);
end;
CircleDemo;
if WaitAKey then exit;
FillEllipseDemo;
if WaitAKey then exit;
RandBarDemo;
if WaitAKey then exit;
XorDemo;
if WaitAKey then exit;
PutImageDemo;
if WaitAKey then exit;
AspectRatioDemo;
if WaitAKey then exit;
FillTriangleDemo;
if WaitAKey then exit;
BarDemo;
if WaitAKey then exit;
Bar3DDemo;
if WaitAKey then exit;
LineStyleDemo;
if WaitAKey then exit;
UserLineStyleDemo;
if WaitAKey then exit;
if FlipDemo then if WaitAKey then exit;
CrtModeDemo;
if WaitAKey then exit;
PolyDemo;
if WaitAKey then exit;
LineToDemo;
if WaitAKey then exit;
end;
{$ifdef __WIN32__}
function SetConsoleTitle conv arg_stdcall (lpConsoleTitle: PChar): Boolean;
external 'kernel32.dll' name 'SetConsoleTitleA';
{$endif}
begin
{$ifdef __WIN32__}
SetConsoleTitle('Graph unit Demo for Win32');
{$endif};
TextMode(CO80);
ClrScr;
repeat
GraphMode:=ModeSelect;
SetGraphMode(GraphMode);
if GraphResult=grOk then begin
DoTest;
CloseGraph;
end else begin
CloseGraph;
Writeln;
Writeln;
Writeln(' Selected mode is not supported.');
Writeln(' Press any key...');
TextBorder('');
ReadKey;
end;
until false;
end.
Соседние файлы в папке GRAPH