program trenatos;
{$ifndef HASAMIGA}
{$fatal This source is compatible with Amiga, AROS and MorphOS only !}
{$endif}
{$h+}{$hints ON}
{
Project : gadtools gadgets example for Trenatos
Details : modified example from RKRM to match request
Reference : RKRM, gadtoolsgadgets.c
Date : 2024-03-17
}
{*
** Simple example of using a number of gadtools gadgets.
*}
uses
exec, agraphics, intuition, gadtools, utility;
{$ifdef AROS}
{* sight, 12 years and still going strong !! outrage ! *}
function GT_GetGadgetAttrs(gad:pGadget; win:pWindow; req:pRequester; Const argv:array of PtrUInt): LONGINT; begin GT_GetGadgetAttrs:=GT_GetGadgetAttrsA(gad,win,req,@argv); end;
procedure GT_SetGadgetAttrs(gad:pGadget; win:pWindow; req:pRequester; Const argv:array of PtrUInt); begin GT_SetGadgetAttrsA(gad,win,req,@argv); end;
function CreateGadget(kind:ULONG; gad:pGadget; ng:pNewGadget; Const argv:array of PtrUInt): pGadget; begin CreateGadget:=CreateGadgetA(kind,gad,ng,@argv); end;
function GetVisualInfo(screen:pScreen; const argv:array of PtrUInt):POINTER; begin GetVisualInfo:=GetVisualInfoA(screen,@argv); end;
{$endif}
type
{*
** Gadget defines of our choosing, to be used as GadgetID's,
** also used as the index into the gadget array my_gads[].
*}
TMyGadgets = (tmgString, tmgCheckBox, tmgRadioBtn, tmgButton);
const
Topaz80 : TTextAttr =
(
ta_Name : 'topaz.font';
ta_YSize : 8;
ta_Style : 0;
ta_Flags : 0;
);
var
// strings used for the radiobuttons. This declaration must
// be similar to ppchar, e.g. terminated with zero.
RadioStrings : array[0..3] of pchar = ('Free Pascal','on','Amiga', nil);
{*
** Print any error message. We could do more fancy handling (like
** an EasyRequest()), but this is only a demo.
*}
procedure errorMessage(error: STRPTR);
begin
if assigned(error)
then WriteLn('Error: ', error);
end;
{*
** Function to handle a GADGETUP or GADGETDOWN event. For GadTools gadgets,
** it is possible to use this function to handle MOUSEMOVEs as well, with
** little or no work.
*}
procedure handleGadgetEvent(win: PWindow; gad: PGadget; code: UWORD; my_gads: array of PGadget);
var
StrBuf : pchar;
CheckBoxStatus : longbool;
SelectedRadioIndex : ulong;
n : integer; // number of requested/returned attributes, if they differ then an error occured.
begin
case TMyGadgets(gad^.GadgetID) of
tmgSTRING:
begin
//* String gadgets report GADGETUP's */
WriteLn('String gadget 1: "', PStringInfo(gad^.SpecialInfo)^.Buffer ,'".');
end;
tmgCheckBox:
begin
writeln('checkbox clicked');
end;
tmgRADIOBTN:
begin
//* String gadgets report GADGETUP's */
WriteLn('radio button clicked');
end;
tmgButton:
begin
//* Buttons report GADGETUP's */
WriteLn('Button was pressed, now displaying some gadget info.');
// obtain and emit info on string gadget
n := GT_GetGadgetAttrs(my_gads[ord(tmgString)], win, nil,
[
GTST_String, AsTag(@StrBuf),
TAG_END
]);
if n = 1 then writeln('string contents = "', StrBuf, '"')
else writeln('unable to obtain contents from string gadget');
// obtain and emit info on CheckBox gadget
n := GT_GetGadgetAttrs(my_gads[ord(tmgCheckBox)], win, nil,
[
GTCB_Checked, AsTag(@CheckBoxStatus),
TAG_END
]);
if n = 1 then writeln('checkbox status = ', CheckBoxStatus)
else writeln('unable to obtain status from CheckBox gadget');
// obtain and emit info on MX gadget
n := GT_GetGadgetAttrs(my_gads[ord(tmgRadioBtn)], win, nil,
[
GTMX_Active, AsTag(@SelectedRadioIndex),
TAG_END
]);
if n = 1 then writeln('selected radio (string) index = ', SelectedRadioIndex)
else writeln('unable to obtain index from RadioBtn (MX) gadget');
end;
end;
end;
{*
** Function to handle vanilla keys.
*}
procedure handleVanillaKey(win: PWindow; code: UWORD; my_gads: array of PGadget);
begin
case chr(code) of
'f', 'F':
begin
ActivateGadget(my_gads[ord(tmgSTRING)], win, nil);
end;
's', 'S':
begin
ActivateGadget(my_gads[ord(tmgCHECKBOX)], win, nil);
end;
't', 'T':
begin
ActivateGadget(my_gads[ord(tmgRADIOBTN)], win, nil);
end;
end;
end;
{*
** Here is where all the initialization and creation of GadTools gadgets
** take place. This function requires a pointer to a NULL-initialized
** gadget list pointer. It returns a pointer to the last created gadget,
** which can be checked for success/failure.
*}
function createAllGadgets(var glistptr: PGadget; vi: Pointer;
topborder: UWORD; var my_gads: array of PGadget): PGadget;
var
ng : TNewGadget;
gad : PGadget;
begin
{*
** All the gadget creation calls accept a pointer to the previous gadget, and
** link the new gadget to that gadget's NextGadget field. Also, they exit
** gracefully, returning NULL, if any previous gadget was NULL. This limits
** the amount of checking for failure that is needed. You only need to check
** before you tweak any gadget structure or use any of its fields, and finally
** once at the end, before you add the gadgets.
*}
{*
** The following operation is required of any program that uses GadTools.
** It gives the toolkit a place to stuff context data.
*}
gad := CreateContext(@glistptr);
{*
** Since the NewGadget structure is unmodified by any of the CreateGadget()
** calls, we need only change those fields which are different.
*}
ng.ng_LeftEdge := 140;
ng.ng_TopEdge := 20 + topborder;
ng.ng_Width := 200;
ng.ng_Height := 12;
ng.ng_GadgetText := '_Volume: ';
ng.ng_TextAttr := @Topaz80;
ng.ng_VisualInfo := vi;
ng.ng_Flags := NG_HIGHLABEL;
// String gadget:
ng.ng_TopEdge := ng.ng_TopEdge + 20;
ng.ng_Height := 14;
ng.ng_GadgetText := '_First:';
ng.ng_GadgetID := ord(tmgSTRING);
gad := CreateGadget(STRING_KIND, gad, @ng,
[
GTST_String , AsTag(PChar('A string gadget')),
GTST_MaxChars , 50,
GA_Immediate , AsTag(true),
GT_Underscore , Ord('_'),
TAG_END
]);
my_gads[ord(tmgSTRING)] := gad;
// CheckBox gadget:
ng.ng_TopEdge := ng.ng_TopEdge + 20;
ng.ng_GadgetText := '_Second:';
ng.ng_GadgetID := ord(tmgCHECKBOX);
gad := CreateGadget(CHECKBOX_KIND, gad, @ng,
[
GT_Underscore , Ord('_'),
TAG_END
]);
my_gads[ord(tmgCHECKBOX)] := gad;
// RadioButtons gadget:
ng.ng_TopEdge := ng.ng_TopEdge + 20;
ng.ng_GadgetText := '_Third:';
ng.ng_GadgetID := ord(tmgRADIOBTN);
gad := CreateGadget(MX_KIND, gad, @ng,
[
GTMX_Labels , AsTag(@RadioStrings[0]),
GT_Underscore , Ord('_'),
TAG_END
]);
my_gads[ord(tmgRADIOBTN)] := gad;
// Button gadget:
ng.ng_LeftEdge := ng.ng_LeftEdge + 50;
ng.ng_TopEdge := ng.ng_TopEdge + 30;
ng.ng_Width := 100;
ng.ng_Height := 12;
ng.ng_GadgetText := '_Click Here';
ng.ng_GadgetID := ord(tmgBUTTON);
ng.ng_Flags := 0;
gad := CreateGadget(BUTTON_KIND, gad, @ng,
[
GT_Underscore , Ord('_'),
TAG_END
]);
createAllGadgets := (gad);
end;
{*
** Standard message handling loop with GadTools message handling functions
** used (GT_GetIMsg() and GT_ReplyIMsg()).
*}
procedure process_window_events(mywin: PWindow; my_gads: array of PGadget);
var
imsg : PIntuiMessage;
imsgClass : ULONG;
imsgCode : UWORD;
gad : PGadget;
terminated : Boolean = false;
begin
while not(terminated) do
begin
Wait(1 shl mywin^.UserPort^.mp_SigBit);
{*
** GT_GetIMsg() returns an IntuiMessage with more friendly information for
** complex gadget classes. Use it wherever you get IntuiMessages where
** using GadTools gadgets.
*}
imsg := GT_GetIMsg(mywin^.UserPort);
while not(terminated) and assigned(iMsg) do
begin
{*
** Presuming a gadget, of course, but no harm...
** Only dereference this value (gad) where the Class specifies
** that it is a gadget event.
*}
gad := PGadget(imsg^.IAddress);
imsgClass := imsg^.IClass;
imsgCode := imsg^.Code;
//* Use the toolkit message-replying function here... */
GT_ReplyIMsg(imsg);
case (imsgClass) of
{*
** --- WARNING --- WARNING --- WARNING --- WARNING --- WARNING ---
** GadTools puts the gadget address into IAddress of IDCMP_MOUSEMOVE
** messages. This is NOT true for standard Intuition messages,
** but is an added feature of GadTools.
*}
IDCMP_GADGETDOWN,
IDCMP_MOUSEMOVE,
IDCMP_GADGETUP:
begin
handleGadgetEvent(mywin, gad, imsgCode, my_gads);
end;
IDCMP_VANILLAKEY:
begin
handleVanillaKey(mywin, imsgCode, my_gads);
end;
IDCMP_CLOSEWINDOW:
begin
terminated := true;
end;
IDCMP_REFRESHWINDOW:
begin
{*
** With GadTools, the application must use GT_BeginRefresh()
** where it would normally have used BeginRefresh()
*}
GT_BeginRefresh(mywin);
GT_EndRefresh(mywin, ord(true));
end;
end;
imsg := GT_GetIMsg(mywin^.UserPort);
end;
end;
end;
{*
** Prepare for using GadTools, set up gadgets and open window.
** Clean up and when done or on error.
*}
procedure gadtoolsWindow;
var
font : PTextFont;
mysc : PScreen;
mywin : PWindow;
glist : PGadget = nil;
vi : Pointer;
topborder : UWORD;
my_gads : array[TMyGadgets] of PGadget;
begin
{*
** Open topaz 8 font, so we can be sure it's openable
** when we later set ng_TextAttr to &Topaz80:
*}
font := OpenFont(@Topaz80);
if not assigned(font) then errorMessage('Failed to open Topaz 80')
else
begin
mysc := LockPubScreen(nil);
if not assigned(mysc) then errorMessage('Couldn''t lock default public screen"')
else
begin
vi := GetVisualInfo(mysc, [TAG_END]);
if not assigned(vi) then errorMessage('GetVisualInfo() failed')
else
begin
//* Here is how we can figure out ahead of time how tall the */
//* window's title bar will be: */
topborder := mysc^.WBorTop + (mysc^.Font^.ta_YSize + 1);
if (nil = createAllGadgets(glist, vi, topborder, my_gads))
then errorMessage('createAllGadgets() failed')
else
begin
mywin := OpenWindowTags(nil,
[
WA_Title , AsTag(pchar('GadTools Gadget Demo')),
WA_Gadgets , AsTag(glist),
WA_AutoAdjust , AsTag(true),
WA_Width , 400,
WA_MinWidth , 60,
WA_InnerHeight , 140,
WA_MinHeight , 60,
WA_DragBar , AsTag(true),
WA_DepthGadget , AsTag(true),
WA_Activate , AsTag(true),
WA_CloseGadget , AsTag(true),
WA_SizeGadget , AsTag(true),
WA_SimpleRefresh, AsTag(true),
WA_IDCMP , IDCMP_CLOSEWINDOW or IDCMP_REFRESHWINDOW or IDCMP_VANILLAKEY or STRINGIDCMP or CHECKBOXIDCMP or MXIDCMP or BUTTONIDCMP,
WA_PubScreen , AsTag(mysc),
TAG_END
]);
if not assigned(mywin)
then errorMessage('OpenWindow() failed')
else
begin
{*
** After window is open, gadgets must be refreshed with a
** call to the GadTools refresh window function.
*}
GT_RefreshWindow(mywin, nil);
process_window_events(mywin, my_gads);
CloseWindow(mywin);
end;
end;
{*
** FreeGadgets() even if createAllGadgets() fails, as some
** of the gadgets may have been created...If glist is NULL
** then FreeGadgets() will do nothing.
*}
FreeGadgets(glist);
FreeVisualInfo(vi);
end;
UnlockPubScreen(nil, mysc);
end;
CloseFont(font);
end;
end;
{*
** Check all libraries and run. Clean up when finished or on error..
*}
begin
if (pLibrary(IntuitionBase)^.lib_version < 37)
then errorMessage('Requires V37 intuition.library')
else
begin
if (pLibrary(GfxBase)^.lib_version < 37)
then errorMessage('Requires V37 graphics.library')
else
begin
if (pLibrary(GadtoolsBase)^.lib_version < 37)
then errorMessage('Requires V37 gadtools.library')
else
begin
gadtoolsWindow;
end;
end;
end;
end.
Recent
