home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 3 / goldfish_volume_3.bin / files / dev / e / amigae / rkrmsrc / gadtools / gadtoolsgadgets.e next >
Text File  |  1995-03-31  |  11KB  |  274 lines
  1. -> gadtoolsgadgets.e
  2. -> Simple example of using a number of gadtools gadgets.
  3.  
  4. MODULE 'gadtools',
  5.        'exec/ports',
  6.        'graphics/text',
  7.        'intuition/intuition',
  8.        'intuition/screens',
  9.        'libraries/gadtools'
  10.  
  11. ENUM ERR_NONE, ERR_FONT, ERR_GAD, ERR_KICK, ERR_LIB, ERR_PUB, ERR_VIS, ERR_WIN
  12.  
  13. RAISE ERR_FONT IF OpenFont()=NIL,
  14.       ERR_GAD  IF CreateGadgetA()=NIL,
  15.       ERR_KICK IF KickVersion()=FALSE,
  16.       ERR_LIB  IF OpenLibrary()=NIL,
  17.       ERR_PUB  IF LockPubScreen()=NIL,
  18.       ERR_VIS  IF GetVisualInfoA()=NIL,
  19.       ERR_WIN  IF OpenWindowTagList()=NIL
  20.  
  21. -> Gadget ENUM to be used as GadgetIDs and also as the indexes into the
  22. -> gadget array my_gads[].
  23. ENUM MYGAD_SLIDER, MYGAD_STRING1, MYGAD_STRING2, MYGAD_STRING3, MYGAD_BUTTON
  24.  
  25. -> Range for the slider:
  26. CONST SLIDER_MIN=1, SLIDER_MAX=20
  27.  
  28. DEF topaz80
  29.  
  30. -> Function to handle a GADGETUP or GADGETDOWN event.  For GadTools gadgets,
  31. -> it is possible to use this function to handle MOUSEMOVEs as well, with
  32. -> little or no work.
  33. -> E-Note: slider_level is not a 'PTR TO INT', but 'PTR TO LONG'
  34. PROC handleGadgetEvent(win, gad:PTR TO gadget, code,
  35.                        slider_level:PTR TO LONG, my_gads:PTR TO LONG)
  36.   DEF id
  37.   id:=gad.gadgetid
  38.   SELECT id
  39.   CASE MYGAD_SLIDER
  40.     -> Sliders report their level in the IntuiMessage Code field:
  41.     WriteF('Slider at level \d\n', code)
  42.     slider_level[]:=code
  43.   CASE MYGAD_STRING1
  44.     -> String gadgets report GADGETUP's
  45.     WriteF('String gadget 1: "\s".\n', gad.specialinfo::stringinfo.buffer)
  46.   CASE MYGAD_STRING2
  47.     -> String gadgets report GADGETUP's
  48.     WriteF('String gadget 2: "\s".\n', gad.specialinfo::stringinfo.buffer)
  49.   CASE MYGAD_STRING3
  50.     -> String gadgets report GADGETUP's
  51.     WriteF('String gadget 3: "\s".\n', gad.specialinfo::stringinfo.buffer)
  52.   CASE MYGAD_BUTTON
  53.     -> Buttons report GADGETUP's (button resets slider to 10)
  54.     WriteF('Button was pressed, slider reset to 10.\n')
  55.     slider_level[]:=10
  56.     Gt_SetGadgetAttrsA(my_gads[MYGAD_SLIDER], win, NIL,
  57.                       [GTSL_LEVEL, slider_level[], NIL])
  58.   ENDSELECT
  59. ENDPROC
  60.  
  61. -> Function to handle vanilla keys.
  62. -> E-Note: slider_level is not a 'PTR TO INT', but 'PTR TO LONG'
  63. PROC handleVanillaKey(win, code, slider_level:PTR TO LONG, my_gads:PTR TO LONG)
  64.   SELECT "w" OF code
  65.   CASE "v"
  66.     -> Increase slider level, but not past maximum
  67.     slider_level[]:=Min(slider_level[]+1, SLIDER_MAX)
  68.     Gt_SetGadgetAttrsA(my_gads[MYGAD_SLIDER], win, NIL,
  69.                       [GTSL_LEVEL, slider_level[], NIL])
  70.   CASE "V"
  71.     -> Decrease slider level, but not past maximum
  72.     slider_level[]:=Max(slider_level[]-1, SLIDER_MIN)
  73.     Gt_SetGadgetAttrsA(my_gads[MYGAD_SLIDER], win, NIL,
  74.                       [GTSL_LEVEL, slider_level[], NIL])
  75.   CASE "c", "C"
  76.     -> Button resets slider to 10
  77.     slider_level[]:=10
  78.     Gt_SetGadgetAttrsA(my_gads[MYGAD_SLIDER], win, NIL,
  79.                       [GTSL_LEVEL, slider_level[], NIL])
  80.   CASE "f", "F"
  81.     ActivateGadget(my_gads[MYGAD_STRING1], win, NIL)
  82.   CASE "s", "S"
  83.     ActivateGadget(my_gads[MYGAD_STRING2], win, NIL)
  84.   CASE "t", "T"
  85.     ActivateGadget(my_gads[MYGAD_STRING3], win, NIL)
  86.   ENDSELECT
  87. ENDPROC
  88.  
  89. -> Here is where all the initialisation and creation of GadTools gadgets take
  90. -> place.  This function requires a pointer to a NIL-initialised gadget list
  91. -> pointer.  It returns a pointer to the last created gadget.
  92. -> E-Note: exceptions raised by CreateGadgetA() will be handled by caller
  93. PROC createAllGadgets(glistptr:PTR TO LONG, vi, topborder,
  94.                       slider_level, my_gads:PTR TO LONG)
  95.   DEF gad, ng:PTR TO newgadget
  96.   -> All the gadget creation calls accept a pointer to the previous gadget, and
  97.   -> link the new gadget to that gadget's NextGadget field.  Also, they exit
  98.   -> gracefully, returning NIL, if any previous gadget was NIL.  This limits
  99.   -> the amount of checking for failure that is needed.  You only need to check
  100.   -> before you tweak any gadget structure or use any of its fields, and
  101.   -> finally once at the end, before you add the gadgets.
  102.  
  103.   -> The following operation is required of any program that uses GadTools.
  104.   -> It gives the toolkit a place to stuff context data.
  105.   gad:=CreateContext(glistptr)
  106.  
  107.   -> Since the NewGadget structure is unmodified by any of the CreateGadgetA()
  108.   -> calls, we need only change those fields which are different.
  109.   ng:=[140, (20+topborder), 200, 12, '_Volume:   ', topaz80,
  110.        MYGAD_SLIDER, NG_HIGHLABEL, vi, 0]:newgadget
  111.  
  112.   my_gads[MYGAD_SLIDER]:=(gad:=CreateGadgetA(SLIDER_KIND, gad, ng,
  113.                                     [GTSL_MIN,         SLIDER_MIN,
  114.                                      GTSL_MAX,         SLIDER_MAX,
  115.                                      GTSL_LEVEL,       slider_level,
  116.                                      GTSL_LEVELFORMAT, '\d[2]',
  117.                                      GTSL_MAXLEVELLEN, 2,
  118.                                      GT_UNDERSCORE,    "_",
  119.                                      NIL]))
  120.  
  121.   ng.topedge    := ng.topedge+20
  122.   ng.height     := 14
  123.   ng.gadgettext := '_First:'
  124.   ng.gadgetid   := MYGAD_STRING1
  125.   my_gads[MYGAD_STRING1]:=(gad:=CreateGadgetA(STRING_KIND, gad, ng,
  126.                                      [GTST_STRING,   'Try pressing',
  127.                                       GTST_MAXCHARS, 50,
  128.                                       GT_UNDERSCORE, "_",
  129.                                       NIL]))
  130.  
  131.   ng.topedge    := ng.topedge+20
  132.   ng.gadgettext := '_Second:'
  133.   ng.gadgetid   := MYGAD_STRING2
  134.   my_gads[MYGAD_STRING2]:=(gad:=CreateGadgetA(STRING_KIND, gad, ng,
  135.                                      [GTST_STRING,   'TAB or Shift-TAB',
  136.                                       GTST_MAXCHARS, 50,
  137.                                       GT_UNDERSCORE, "_",
  138.                                       NIL]))
  139.  
  140.   ng.topedge    := ng.topedge+20
  141.   ng.gadgettext := '_Third:'
  142.   ng.gadgetid   := MYGAD_STRING3
  143.   my_gads[MYGAD_STRING3]:=(gad:=CreateGadgetA(STRING_KIND, gad, ng,
  144.                                      [GTST_STRING,   'To see what happens!',
  145.                                       GTST_MAXCHARS, 50,
  146.                                       GT_UNDERSCORE, "_",
  147.                                       NIL]))
  148.  
  149.   ng.leftedge   := 50
  150.   ng.topedge    := 20
  151.   ng.width      := 100
  152.   ng.height     := 12
  153.   ng.gadgettext := '_Click Here'
  154.   ng.gadgetid   := MYGAD_BUTTON
  155.   ng.flags      := 0
  156.   gad:=CreateGadgetA(BUTTON_KIND, gad, ng,
  157.                     [GT_UNDERSCORE, "_", NIL])
  158. ENDPROC gad
  159.  
  160. -> Standard message handling loop with GadTools message handling functions
  161. -> used (Gt_GetIMsg() and Gt_ReplyIMsg()).
  162. -> E-Note: slider_level is not a 'PTR TO INT', but 'PTR TO LONG'
  163. PROC process_window_events(mywin:PTR TO window, slider_level:PTR TO LONG,
  164.                            my_gads:PTR TO LONG)
  165.   DEF imsg:PTR TO intuimessage, imsgClass, imsgCode, gad, terminated=FALSE
  166.   REPEAT
  167.     Wait(Shl(1, mywin.userport.sigbit))
  168.  
  169.     -> Gt_GetIMsg() returns an IntuiMessage with more friendly information for
  170.     -> complex gadget classes.  Use it wherever you get IntuiMessages where
  171.     -> using GadTools gadgets.
  172.     WHILE (terminated=FALSE) AND (imsg:=Gt_GetIMsg(mywin.userport))
  173.       -> Presuming a gadget, of course, but no harm...  Only dereference this
  174.       -> value (gad) where the Class specifies that it is a gadget event.
  175.       gad:=imsg.iaddress
  176.  
  177.       imsgClass:=imsg.class
  178.       imsgCode:=imsg.code
  179.  
  180.       -> Use the toolkit message-replying function here...
  181.       Gt_ReplyIMsg(imsg)
  182.  
  183.       SELECT imsgClass
  184.         ->  --- WARNING --- WARNING --- WARNING --- WARNING --- WARNING ---
  185.         -> GadTools puts the gadget address into IAddress of IDCMP_MOUSEMOVE
  186.         -> messages.  This is NOT true for standard Intuition messages,
  187.         -> but is an added feature of GadTools.
  188.       CASE IDCMP_GADGETDOWN
  189.         handleGadgetEvent(mywin, gad, imsgCode, slider_level, my_gads)
  190.       CASE IDCMP_MOUSEMOVE
  191.         handleGadgetEvent(mywin, gad, imsgCode, slider_level, my_gads)
  192.       CASE IDCMP_GADGETUP
  193.         handleGadgetEvent(mywin, gad, imsgCode, slider_level, my_gads)
  194.  
  195.       CASE IDCMP_VANILLAKEY
  196.         handleVanillaKey(mywin, imsgCode, slider_level, my_gads)
  197.       CASE IDCMP_CLOSEWINDOW
  198.         terminated:=TRUE
  199.       CASE IDCMP_REFRESHWINDOW
  200.         -> With GadTools, the application must use Gt_BeginRefresh()
  201.         -> where it would normally have used BeginRefresh()
  202.         Gt_BeginRefresh(mywin)
  203.         Gt_EndRefresh(mywin, TRUE)
  204.       ENDSELECT
  205.     ENDWHILE
  206.   UNTIL terminated
  207. ENDPROC
  208.  
  209. -> Prepare for using GadTools, set up gadgets and open window.
  210. -> Clean up and when done or on error.
  211. PROC gadtoolsWindow() HANDLE
  212.   DEF font=NIL, mysc=NIL:PTR TO screen, mywin=NIL, glist=NIL,
  213.       my_gads[4]:ARRAY OF LONG, vi, slider_level=5, topborder
  214.   -> Open topaz 8 font, so we can be sure it's openable when we later
  215.   -> set ng.textattr to Topaz80:
  216.   topaz80:=['topaz.font', 8, 0, 0]:textattr
  217.   font:=OpenFont(topaz80)
  218.   mysc:=LockPubScreen(NIL)
  219.   vi:=GetVisualInfoA(mysc, [NIL])
  220.  
  221.   -> Here is how we can figure out ahead of time how tall the window's
  222.   -> title bar will be:
  223.   topborder:=mysc.wbortop+mysc.font.ysize+1
  224.  
  225.   createAllGadgets({glist}, vi, topborder, slider_level, my_gads)
  226.  
  227.   mywin:=OpenWindowTagList(NIL,
  228.                      [WA_TITLE, 'GadTools Gadget Demo',
  229.                       WA_GADGETS,   glist,  WA_AUTOADJUST,    TRUE,
  230.                       WA_WIDTH,       400,  WA_MINWIDTH,        50,
  231.                       WA_INNERHEIGHT, 140,  WA_MINHEIGHT,       50,
  232.                       WA_DRAGBAR,    TRUE,  WA_DEPTHGADGET,   TRUE,
  233.                       WA_ACTIVATE,   TRUE,  WA_CLOSEGADGET,   TRUE,
  234.                       WA_SIZEGADGET, TRUE,  WA_SIMPLEREFRESH, TRUE,
  235.                       WA_IDCMP, IDCMP_CLOSEWINDOW OR IDCMP_REFRESHWINDOW OR
  236.                                 IDCMP_VANILLAKEY OR SLIDERIDCMP OR
  237.                                 STRINGIDCMP OR BUTTONIDCMP,
  238.                       WA_PUBSCREEN, mysc,
  239.                       NIL])
  240.   -> After window is open, gadgets must be refreshed with a call to the
  241.   -> GadTools refresh window function.
  242.   Gt_RefreshWindow(mywin, NIL)
  243.  
  244.   process_window_events(mywin, {slider_level}, my_gads)
  245.  
  246. EXCEPT DO
  247.   IF mywin THEN CloseWindow(mywin)
  248.   -> FreeGadgets() even if createAllGadgets() fails, as some of the gadgets may
  249.   -> have been created...  If glist is NIL then FreeGadgets() will do nothing.
  250.   FreeGadgets(glist)
  251.   IF vi THEN FreeVisualInfo(vi)
  252.   IF mysc THEN UnlockPubScreen(mysc, NIL)
  253.   IF font THEN CloseFont(font)
  254.   ReThrow()  -> E-Note: pass on exception if it was an error
  255. ENDPROC
  256.  
  257. -> Open all libraries and run.  Clean up when finished or on error..
  258. PROC main() HANDLE
  259.   KickVersion(37)
  260.   gadtoolsbase:=OpenLibrary('gadtools.library', 37)
  261.   gadtoolsWindow()
  262. EXCEPT DO
  263.   IF gadtoolsbase THEN CloseLibrary(gadtoolsbase)
  264.   SELECT exception
  265.   CASE ERR_FONT; WriteF('Error: Failed to open Topaz 80\n')
  266.   CASE ERR_GAD;  WriteF('Error: createAllGadgets() failed\n')
  267.   CASE ERR_KICK; WriteF('Error: Requires V37\n')
  268.   CASE ERR_LIB;  WriteF('Error: Requires V37 gadtools.library\n')
  269.   CASE ERR_PUB;  WriteF('Error: Couldn''t lock default public screen\n')
  270.   CASE ERR_VIS;  WriteF('Error: GetVisualInfoA() failed\n')
  271.   CASE ERR_WIN;  WriteF('Error: OpenWindow() failed\n')
  272.   ENDSELECT
  273. ENDPROC
  274.