Graphics: Delphi Version
{*****************************************************************************
* *
* Graphics.dpr *
* GraphicsU.pas *
* *
* This program demonstrates some of the Fastgraph for Windows graphics *
* primitive functions. *
* *
*****************************************************************************}
unit GraphicsU;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Menus, FGWin;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
Points: TMenuItem;
Lines: TMenuItem;
Rectangles: TMenuItem;
Circles: TMenuItem;
Ellipses: TMenuItem;
Polygons: TMenuItem;
Paint: TMenuItem;
Exit1: TMenuItem;
procedure AppOnActivate(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PointsClick(Sender: TObject);
procedure LinesClick(Sender: TObject);
procedure RectanglesClick(Sender: TObject);
procedure CirclesClick(Sender: TObject);
procedure EllipsesClick(Sender: TObject);
procedure PolygonsClick(Sender: TObject);
procedure PaintClick(Sender: TObject);
procedure ExitClick(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$J+}
{$R *.DFM}
const
vbWidth = 640;
vbHeight = 480;
var
dc : hDC;
hPal : hPalette;
hVB : integer;
cxClient, cyClient : integer;
{*****************************************************************************
* *
* Blit() *
* *
* Use fg_vbpaste() or fg_vbscale() to display the virtual buffer contents *
* in the client area, depending on the size of the client window. *
* *
*****************************************************************************}
procedure Blit;
begin
if (cxClient > vbWidth) or (cyClient > vbHeight) then {window > 640x480}
fg_vbscale(0,vbWidth-1,0,vbHeight-1,0,cxClient-1,0,cyClient-1)
else
fg_vbpaste(0,vbWidth-1,0,vbHeight-1,0,cyClient-1);
end;
procedure TForm1.AppOnActivate(Sender: TObject);
begin
fg_realize(hPal);
Invalidate;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
fg_realize(hPal);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
dc := GetDC(Form1.Handle);
fg_setdc(dc);
hPal := fg_defpal;
fg_realize(hPal);
Left := 0;
Top := 0;
Width := vbWidth;
Height := vbHeight;
fg_vbinit;
hVB := fg_vballoc(vbWidth,vbHeight);
fg_vbopen(hVB);
fg_vbcolors;
fg_setcolor(25);
fg_fillpage;
Application.OnActivate := AppOnActivate;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Blit;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
cxClient := ClientWidth;
cyClient := ClientHeight;
Invalidate;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
fg_vbclose;
fg_vbfree(hVB);
fg_vbfin;
DeleteObject(hPal);
ReleaseDC(Form1.Handle,dc);
end;
{*****************************************************************************
* *
* PointsClick() *
* *
* Draw a pattern of points. *
* *
*****************************************************************************}
procedure TForm1.PointsClick(Sender: TObject);
var
x, y : integer;
begin
{ fill the virtual buffer with yellow pixels }
fg_setcolor(24);
fg_fillpage;
{ draw the patterns of points }
fg_setcolor(19);
x := 7;
while (x < vbWidth) do
begin
y := 0;
while (y < vbHeight) do
begin
fg_point(x,y);
inc(y,8);
end;
inc(x,20);
end;
fg_setcolor(22);
x := 17;
while (x < vbWidth) do
begin
y := 4;
while (y < vbHeight) do
begin
fg_point(x,y);
inc(y,8);
end;
inc(x,20);
end;
Blit;
end;
{*****************************************************************************
* *
* LinesClick() *
* *
* Draw a pattern of solid lines. *
* *
*****************************************************************************}
procedure TForm1.LinesClick(Sender: TObject);
const
line_color : array [0..7] of integer = (12,11,19,21,21,19,11,12);
var
i, x, y, x1, x2, y1 : integer;
begin
fg_setcolor(25);
fg_fillpage;
{ draw horizontal lines }
y := 0;
while (y < vbHeight) do
begin
for i := 0 to 7 do
begin
fg_setcolor(line_color[i]);
y1 := y + 3*i;
fg_move(0,y1);
fg_draw(vbWidth-1,y1);
end;
inc(y,40);
end;
{ draw vertical lines }
x := 0;
while (x < vbWidth) do
begin
for i := 0 to 7 do
begin
fg_setcolor(line_color[i]);
x1 := x + 3*i;
fg_move(x1,0);
fg_draw(x1,vbHeight-1);
end;
inc(x,60);
end;
{ draw red diagonal lines }
fg_setcolor(22);
x1 := -640;
while (x1 < 640) do
begin
x2 := x1 + vbHeight;
fg_move(x1,0);
fg_draw(x2,vbHeight);
inc(x1,60);
end;
x1 := 0;
while (x1 < 1280) do
begin
x2 := x1 - vbHeight;
fg_move(x1,0);
fg_draw(x2,vbHeight);
inc(x1,60);
end;
Blit;
end;
{*****************************************************************************
* *
* RectanglesClick() *
* *
* Draw a grid of filled rectangles. *
* *
*****************************************************************************}
procedure TForm1.RectanglesClick(Sender: TObject);
var
i, j, color : integer;
x1, x2, y1, y2 : integer;
xinc, yinc : integer;
begin
x1 := 0;
xinc := vbWidth div 10;
x2 := xinc - 1;
y1 := 0;
yinc := vbHeight div 10;
y2 := yinc - 1;
color := 10;
{ draw 100 filled rectangles (10 rows of 10) }
for i := 1 to 10 do
begin
for j := 1 to 10 do
begin
fg_setcolor(color);
fg_rect(x1,x2,y1,y2);
inc(color);
if (color > 24) then color := 10;
inc(x1,xinc);
inc(x2,xinc);
end;
x1 := 0;
x2 := xinc - 1;
inc(y1,yinc);
inc(y2,yinc);
end;
Blit;
end;
{*****************************************************************************
* *
* CirclesClick() *
* *
* Draw a series of concentric circles. *
* *
*****************************************************************************}
procedure TForm1.CirclesClick(Sender: TObject);
var
i, radius : integer;
begin
fg_setcolor(11);
fg_fillpage;
{ draw 25 concentric circles at the center of the virtual buffer }
fg_move(vbWidth div 2,vbHeight div 2);
radius := 4;
fg_setcolor(25);
for i := 1 to 25 do
begin
fg_circle(radius);
inc(radius,8);
end;
Blit;
end;
{*****************************************************************************
* *
* EllipsesClick() *
* *
* Draw a series of concentric ellipses. *
* *
*****************************************************************************}
procedure TForm1.EllipsesClick(Sender: TObject);
var
i, horiz, vert : integer;
begin
fg_setcolor(11);
fg_fillpage;
{ draw 80 concentric ellipses at the center of the virtual buffer }
fg_move(vbWidth div 2,vbHeight div 2);
horiz := 4;
vert := 1;
fg_setcolor(25);
for i := 1 to 80 do
begin
fg_ellipse(horiz,vert);
inc(horiz,3);
inc(vert);
end;
Blit;
end;
{*****************************************************************************
* *
* PolygonsClick() *
* *
* Draw a grid of filled polygons. *
* *
*****************************************************************************}
procedure TForm1.PolygonsClick(Sender: TObject);
const
xyDarkBlue : array [0..7] of integer = (0,16, 24,0, 24,40, 0,56);
xyLightBlue : array [0..7] of integer = (24,0, 72,0, 72,40, 24,40);
xyGreen : array [0..7] of integer = (0,56, 24,40, 72,40, 48,56);
var
i, j : integer;
begin
fg_setcolor(25);
fg_fillpage;
{ draw 225 filled polygons (15 rows of 15) }
for j := 0 to 14 do
begin
for i := 0 to 14 do
begin
fg_polyoff(i*72-j*24,j*56-i*16);
fg_setcolor(11);
fg_polyfill(xyDarkBlue,nil^,4);
fg_setcolor(19);
fg_polyfill(xyLightBlue,nil^,4);
fg_setcolor(20);
fg_polyfill(xyGreen,nil^,4);
end;
end;
Blit;
end;
{*****************************************************************************
* *
* PaintClick() *
* *
* Demonstrate region fill. *
* *
*****************************************************************************}
procedure TForm1.PaintClick(Sender: TObject);
var
x1, x2, y1, y2 : integer;
begin
fg_setcolor(25);
fg_fillpage;
{ draw a rectangle }
x1 := 40;
x2 := vbWidth - 40;
y1 := 20;
y2 := vbHeight - 20;
fg_setcolor(21);
fg_rect(x1,x2,y1,y2);
{ outline the rectangle }
fg_setcolor(10);
fg_box(x1,x2,y1,y2);
{ draw the circle }
x1 := vbWidth div 2;
y1 := vbHeight div 2;
fg_move(x1,y1);
fg_circle(80);
{ draw cross bars in the circle }
fg_move(x1,y1-80);
fg_draw(x1,y1+80);
fg_move(x1-80,y1);
fg_draw(x1+80,y1);
{ paint each quarter of the circle }
fg_setcolor(11);
fg_paint(x1-6,y1-6);
fg_setcolor(12);
fg_paint(x1+6,y1+6);
fg_setcolor(13);
fg_paint(x1+6,y1-6);
fg_setcolor(14);
fg_paint(x1-6,y1+6);
{ paint the area outside the box }
fg_setcolor(24);
fg_paint(41,21);
Blit;
end;
procedure TForm1.ExitClick(Sender: TObject);
begin
Close;
end;
end.
|