Examplecode
Jump to navigation
Jump to search
Some example-code that need preperation before they can go into the wikibook.
Original c-code [1]
Program HelloWorld;
Begin
Writeln('Hello World');
Exit(0);
End.
Original c-code [2]
Program graphics_simple;
{$MODE OBJFPC} {$H+}
(*
Example for simple drawing routines
*)
Uses
chelpers,
amigalib,
aros_exec,
aros_graphics,
aros_intuition,
aros_utility;
var
window : pWindow;
cm : pColorMap;
rp : pRastPort;
const
(*
ObtainBestPen() returns -1 when it fails, therefore we
initialize the pen numbers with -1 to simplify cleanup.
*)
pen1 : A_LONG = -1;
pen2 : A_LONG = -1;
{ forward declarations }
procedure draw_simple; forward;
procedure clean_exit(const s: A_CONST_STRPTR); forward;
procedure handle_events; forward;
Function Main: Integer;
begin
window := OpenWindowTags(nil,
[
WA_Left , 50,
WA_Top , 70,
WA_Width , 400,
WA_Height , 350,
WA_Title , 'Simple Graphics',
WA_Activate , True,
WA_SmartRefresh , true,
WA_NoCareRefresh, true,
WA_GimmeZeroZero, true,
WA_CloseGadget , true,
WA_DragBar , true,
WA_DepthGadget , true,
WA_IDCMP , IDCMP_CLOSEWINDOW,
TAG_END
]);
if not valid(window) then clean_exit('Can''t open window');
rp := window^.RPort;
cm := pScreen(window^.WScreen)^.ViewPort.Colormap;
(* Let's obtain two pens *)
{
pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END);
pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END);
}
pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil);
pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil);
If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen');
draw_simple;
handle_events;
clean_exit(nil);
result := 0;
end;
procedure draw_simple;
var
array_ : array[0..8-1] of A_WORD;
begin
array_[0] := 50; array_[1] := 200; { Polygon for PolyDraw }
array_[2] := 80; array_[3] := 180;
array_[4] := 90; array_[5] := 220;
array_[6] := 50; array_[7] := 200;
SetAPen(rp, pen1); { Set foreground color }
SetBPen(rp, pen2); { Set background color }
WritePixel(rp, 30, 70); { Plot a point }
SetDrPt(rp, $FF00); { Change line pattern. Set pixels are drawn }
{ with APen, unset with BPen }
Move(rp, 20, 50); { Move cursor to given point }
Draw(rp, 100, 80); { Draw a line from current to given point }
DrawEllipse(rp, 70, 30, 15, 10); { Draw an ellipse }
(*
Draw a polygon. Note that the first line is draw from the
end of the last Move() or Draw() command
*)
PolyDraw(rp, sizeof(array_) div sizeof(A_WORD) div 2, @array_);
SetDrMd(rp, JAM1); { We want to use only the foreground pen }
Move(rp, 200, 80);
GText(rp, 'Text in default font', 20);
SetDrPt(rp, $FFFF); { Reset line pattern }
end;
procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG);
begin
SetDrMd(rp, mode);
Move(rp, x, y);
GText(rp, s, strlen(s));
end;
procedure handle_events;
var
imsg : pIntuiMessage;
port : pMsgPort;
terminated : boolean;
begin
(*
A simple event handler. This will be exaplained ore detailed
in the Intuition examples.
*)
port := window^.userPort;
terminated := false;
while not terminated do
begin
Wait(1 shl port^.mp_SigBit);
if (Assign(imsg, GetMsg(port)) <> nil) then
begin
Case imsg^.IClass of
IDCMP_CLOSEWINDOW : terminated := true;
end; { case }
ReplyMsg(pMessage(imsg));
end;
end;
end;
procedure clean_exit(const s: A_CONST_STRPTR);
begin
If valid(s) then WriteLn(s);
(* Give back allocated resources *)
if (pen1 <> -1) then ReleasePen(cm, pen1);
if (pen2 <> -1) then ReleasePen(cm, pen2);
if valid(window) then CloseWindow(window);
end;
Begin
Main();
end.
Original c-code [3]
Program graphics_bitmap;
{$MODE OBJFPC} {$H+}
(*
Example for bitmaps
*)
Uses
chelpers,
amigalib,
aros_exec,
aros_graphics,
aros_intuition,
aros_utility;
var
window : pWindow;
cm : pColorMap;
win_rp : pRastPort;
Const
BMWIDTH = (50);
BMHEIGHT = (50);
var
bm : pBitmap;
bm_rp : pRastPort;
const
(*
ObtainBestPen() returns -1 when it fails, therefore we
initialize the pen numbers with -1 to simplify cleanup.
*)
pen1 : A_LONG = -1;
pen2 : A_LONG = -1;
{ forward declarations }
procedure draw_bitmap; forward;
procedure clean_exit(const s: A_CONST_STRPTR); forward;
procedure handle_events; forward;
{
function RASSIZE(w: integer; h: Integer): Integer; inline;
begin
result := ( (h) * ( ((w)+15) shr 3 and $FFFE ));
end;
}
Procedure DrawCircle(rp: pRastPort; cx: A_LONG; cy: A_LONG; r:A_LONG); inline;
begin
DrawEllipse(rp, cx, cy, r, r);
end;
Function Main: Integer;
begin
window := OpenWindowTags(nil,
[
WA_Left , 50,
WA_Top , 70,
WA_Width , 400,
WA_Height , 350,
WA_Title , 'Bitmap Graphics',
WA_Activate , True,
WA_SmartRefresh , true,
WA_NoCareRefresh, true,
WA_GimmeZeroZero, true,
WA_CloseGadget , true,
WA_DragBar , true,
WA_DepthGadget , true,
WA_IDCMP , IDCMP_CLOSEWINDOW,
TAG_END
]);
if not valid(window) then clean_exit('Can''t open window');
win_rp := window^.RPort;
cm := pScreen(window^.WScreen)^.ViewPort.Colormap;
(* Let's obtain two pens *)
{
pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END);
pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END);
}
pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil);
pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil);
If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen');
draw_bitmap;
handle_events;
clean_exit(nil);
result := 0;
end;
procedure draw_bitmap;
var
Depth : A_UWORD; x: integer;
begin
(*
Get the depth of the screen. Don't peek in the structures, always use
GetBitMapAttr().
*)
depth := GetBitMapAttr(win_rp^.BitMap, BMA_DEPTH);
(*
Create new bitmap. With BMF_MINPLANES and the bitmap pointer we are saying
that we want a bitmap which is smaller than the target bitmap.
*)
bm := AllocBitMap(BMWIDTH, BMHEIGHT, depth, BMF_MINPLANES, win_rp^.BitMap);
if not valid(bm) then clean_exit('Can''t allocate bitmap');
bm_rp := CreateRastPort; { create rastport for our bitmap }
if not valid(bm_rp) then clean_exit('Can''t allocate rastport!');
bm_rp^.Bitmap := bm;
(*
Now we can draw into our bitmap. Take care that the bitmap has no
clipping rectangle. This means we must not draw over the limits.
*)
SetRast(bm_rp, 0); { fill whole bitmap with color 0 }
SetAPen(bm_rp, pen1);
DrawCircle(bm_rp, 24, 24, 24);
SetAPen(bm_rp, pen2);
move(bm_rp, 0, 0);
Draw(bm_rp, 49, 49);
Move(bm_rp, 49, 0);
Draw(bm_rp, 0, 49);
Draw(bm_rp, 49, 49);
Draw(bm_rp, 49, 0);
Draw(bm_rp, 0, 0);
Draw(bm_rp, 0, 49);
{ for x := 20 to pred(400) step 30 do }
x := 20;
while x < 400 do
begin
(* Blit the bitmap into the window *)
ClipBlit(bm_rp, 0, 0, win_rp, x, x div 2, BMWIDTH, BMHEIGHT, $C0);
inc(x, 30);
end;
end;
procedure handle_events;
var
imsg : pIntuiMessage;
port : pMsgPort;
terminated : boolean;
begin
(*
A simple event handler. This will be exaplained ore detailed
in the Intuition examples.
*)
port := window^.userPort;
terminated := false;
while not terminated do
begin
Wait(1 shl port^.mp_SigBit);
if (Assign(imsg, GetMsg(port)) <> nil) then
begin
Case imsg^.IClass of
IDCMP_CLOSEWINDOW : terminated := true;
end; { case }
ReplyMsg(pMessage(imsg));
end;
end;
end;
procedure clean_exit(const s: A_CONST_STRPTR);
begin
If valid(s) then WriteLn(s);
(* Give back allocated resources *)
if valid(bm) then FreeBitMap(bm);
if valid(bm_rp) then FreeRastPort(bm_rp);
if (pen1 <> -1) then ReleasePen(cm, pen1);
if (pen2 <> -1) then ReleasePen(cm, pen2);
if valid(window) then CloseWindow(window);
end;
Begin
Main();
end.
Original c-code [4]
Program graphics_area;
{$MODE OBJFPC} {$H+}
(*
Example for area drawing routines
*)
Uses
chelpers,
amigalib,
aros_exec,
aros_graphics,
aros_intuition,
aros_utility;
var
window : pWindow;
cm : pColorMap;
rp : pRastPort;
const
(*
ObtainBestPen() returns -1 when it fails, therefore we
initialize the pen numbers with -1 to simplify cleanup.
*)
pen1 : A_LONG = -1;
pen2 : A_LONG = -1;
MAX_POINTS = 50;
var
ai : TAreaInfo;
tr : TTmpRas;
trbuf : Pointer;
aibuf : array[0..(MAX_POINTS+1)*5] of A_UBYTE;
{ forward declarations }
procedure draw_area; forward;
procedure clean_exit(const s: A_CONST_STRPTR); forward;
procedure handle_events; forward;
function RASSIZE(w: integer; h: Integer): Integer; inline;
begin
result := ( (h) * ( ((w)+15) shr 3 and $FFFE ));
end;
Function Main: Integer;
begin
window := OpenWindowTags(nil,
[
WA_Left, 50,
WA_Top, 70,
WA_Width, 400,
WA_Height, 350,
WA_Title, 'Area Graphics',
WA_Activate, True,
WA_SmartRefresh, true,
WA_NoCareRefresh, true,
WA_GimmeZeroZero, true,
WA_CloseGadget, true,
WA_DragBar, true,
WA_DepthGadget, true,
WA_IDCMP, IDCMP_CLOSEWINDOW,
TAG_END
]);
if not valid(window) then clean_exit('Can''t open window');
rp := window^.RPort;
cm := pScreen(window^.WScreen)^.ViewPort.Colormap;
(* Let's obtain two pens *)
{
pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END);
pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END);
}
pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil);
pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil);
If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen');
draw_area;
handle_events;
clean_exit(nil);
result := 0;
end;
procedure draw_area;
begin
(*
The area drawing functions need two additional
structures, which have to be linked with the rastport.
First we set the AreaInfo.
The size of 'aibuf' must be at least 5 times the number
of vertexes.
Take care: when you define the variable 'aibuf' locally, you
have to set all fields to 0.
*)
InitArea(@ai, @aibuf, sizeOf(aibuf) div 5);
(*
Then we allocate a raster. It must have the size of
the drawing area. We have a GimmeZeroZero window with
no size gadget, therefore we can use the GZZ sizes.
*)
trbuf := AllocRaster(window^.GZZWidth, window^.GZZHeight);
if not valid(trbuf) then clean_exit('TmpRas buffer allocation failed!');
(*
The raster must be initialized. The reason for RASSIZE() is
that we must round up the width to a 16 bit value
*)
InitTmpRas(@tr, trbuf, RASSIZE(window^.GZZWidth, Window^.GZZHeight));
rp^.AreaInfo := @ai; { Link areainfo to rastport }
rp^.TmpRas := @tr; { Link tempras to rastport }
SetAPen(rp, pen1); { Set foreground color }
SetBPen(rp, pen2); { Set background color }
AreaMove(rp, 50, 200); { set start point of 1st triangle }
AreaDraw(rp, 300, 100);
AreaDraw(rp, 280, 300);
AreaMove(rp, 200, 50); { Set start point of 2nd triangle }
AreaDraw(rp, 210, 100);
AreaDraw(rp, 300, 75);
AreaEllipse(rp, 70, 70, 40, 30); { Add an ellipse }
AreaEnd(rp); { Do the rendering }
end;
procedure handle_events;
var
imsg : pIntuiMessage;
port : pMsgPort;
terminated : boolean;
begin
(*
A siple event handler. This will be exaplained ore detailed
in the Intuition examples.
*)
port := window^.userPort;
terminated := false;
while not terminated do
begin
Wait(1 shl port^.mp_SigBit);
if (Assign(imsg, GetMsg(port)) <> nil) then
begin
Case imsg^.IClass of
IDCMP_CLOSEWINDOW : terminated := true;
end; { case }
ReplyMsg(pMessage(imsg));
end;
end;
end;
procedure clean_exit(const s: A_CONST_STRPTR);
begin
If valid(s) then WriteLn(s);
(* Give back allocated resources *)
if valid(trbuf) then FreeRaster(trbuf, window^.GZZWidth, window^.GZZHeight);
if (pen1 <> -1) then ReleasePen(cm, pen1);
if (pen2 <> -1) then ReleasePen(cm, pen2);
if valid(window) then CloseWindow(window);
end;
Begin
Main();
end.
Original c-code [5]
Program graphics_font;
{$MODE OBJFPC} {$H+}
(*
Example for fonts
*)
Uses
chelpers,
amigalib,
aros_exec,
aros_graphics,
aros_intuition,
aros_diskfont,
aros_utility;
var
window : pWindow;
cm : pColorMap;
rp : pRastPort;
font : pTextFont;
const
(*
ObtainBestPen() returns -1 when it fails, therefore we
initialize the pen numbers with -1 to simplify cleanup.
*)
pen1 : A_LONG = -1;
pen2 : A_LONG = -1;
{ forward declarations }
procedure draw_font; forward;
procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG); forward;
procedure clean_exit(const s: A_CONST_STRPTR); forward;
procedure handle_events; forward;
Function Main: Integer;
begin
window := OpenWindowTags(nil,
[
WA_Left , 50,
WA_Top , 70,
WA_Width , 400,
WA_Height , 350,
WA_Title , 'Fonts',
WA_Activate , True,
WA_SmartRefresh , true,
WA_NoCareRefresh, true,
WA_GimmeZeroZero, true,
WA_CloseGadget , true,
WA_DragBar , true,
WA_DepthGadget , true,
WA_IDCMP , IDCMP_CLOSEWINDOW,
TAG_END
]);
if not valid(window) then clean_exit('Can''t open window');
rp := window^.RPort;
cm := pScreen(window^.WScreen)^.ViewPort.Colormap;
(* Let's obtain two pens *)
{
pen1 := ObtainBestPen(cm, $FFFF0000, 0, 0, TAG_END);
pen2 := ObtainBestPen(cm, 0 ,0, $FFFF0000, TAG_END);
}
pen1 := ObtainBestPenA(cm, $FFFF0000, 0, 0, nil);
pen2 := ObtainBestPenA(cm, 0 ,0, $FFFF0000, nil);
If (not valid(pen1) or not valid(pen2)) then clean_exit('Can''t allocate pen');
draw_font;
handle_events;
clean_exit(nil);
result := 0;
end;
procedure draw_font;
var
style : A_ULONG;
ta : TTextAttr;
begin
ta.ta_name := 'arial.font'; { Font name }
ta.ta_YSize := 15; { Font size }
ta.ta_Style := FSF_ITALIC or FSF_BOLD; { Font style }
ta.ta_Flags := 0;
if not valid(assign(font, OpenDiskFont(@ta))) then
begin
clean_exit('Can''t open font');
end;
SetAPen(rp, pen1);
SetBPen(rp, pen2);
SetFont(rp, font); { Linking the font to the rastport }
(*
In the TextAttr above we've queried a font with the styles italic and bold.
OpenDiskFont() tries to open a font with this styles. If this fails
the styles have to be generated algorithmically. To avoid that a
style will be added to a font which has already the style intrinsically,
we've first to ask. AskSoftStyle() returns a mask where all bits for styles
which have to be added algorithmically are set.
*)
style := AskSoftStyle(rp);
(*
We finally set the style. SetSoftStyle() compares with the mask from
AskSoftStyle() to avoid that an intrinsic style is applied again.
*)
SetSoftStyle(rp, style, FSF_ITALIC or FSF_BOLD);
(*
Now we write some text. Additionally the effects of the
rastport modes are demonstrated
*)
write_text('JAM1' , 100, 60, JAM1);
write_text('JAM2' , 100, 80, JAM2);
write_text('COMPLEMENT' , 100, 100, COMPLEMENT);
write_text('INVERSVID' , 100, 120, INVERSVID);
write_text('JAM1|INVERSVID' , 100, 140, JAM1 or INVERSVID);
write_text('JAM2|INVERSVID' , 100, 160, JAM2 or INVERSVID);
write_text('COMPLEMENT|INVERSVID' , 100, 180, COMPLEMENT or INVERSVID);
end;
procedure write_text(const s: A_CONST_STRPTR; x: A_WORD; y: A_WORD; mode: A_ULONG);
begin
SetDrMd(rp, mode);
Move(rp, x, y);
GText(rp, s, strlen(s));
end;
procedure handle_events;
var
imsg : pIntuiMessage;
port : pMsgPort;
terminated : boolean;
begin
(*
A simple event handler. This will be exaplained ore detailed
in the Intuition examples.
*)
port := window^.userPort;
terminated := false;
while not terminated do
begin
Wait(1 shl port^.mp_SigBit);
if (Assign(imsg, GetMsg(port)) <> nil) then
begin
Case imsg^.IClass of
IDCMP_CLOSEWINDOW : terminated := true;
end; { case }
ReplyMsg(pMessage(imsg));
end;
end;
end;
procedure clean_exit(const s: A_CONST_STRPTR);
begin
If valid(s) then WriteLn(s);
(* Give back allocated resources *)
if (pen1 <> -1) then ReleasePen(cm, pen1);
if (pen2 <> -1) then ReleasePen(cm, pen2);
if valid(font) then CloseFont(font);
if valid(window) then CloseWindow(window);
end;
Begin
Main();
end.
Original c-code []
Original c-code []
Original c-code []
Original c-code []
Original c-code []
Original c-code []
Original c-code []