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