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.

<< Prev

Next >>

Contents
Fastgraph Home Page

 

copyright 2001 Ted Gruber Software, Inc.