home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / M2V11-1.LHA / modula / examples / src / GadToolsGadgets.mod < prev    next >
Encoding:
Text File  |  1994-10-03  |  11.5 KB  |  377 lines
  1. MODULE GadToolsGadgets ; (* RKRM example *)
  2.  
  3. FROM SYSTEM IMPORT STRING,ADR ;
  4.  
  5. IMPORT
  6.   G  := Graphics{37},
  7.   I  := Intuition{37},
  8.   GT := GadTools{37},
  9.   D  := Dos{37},
  10.   E  := Exec,
  11.   U  := Utility,
  12.   SL := StdLib ;
  13.  
  14. PROCEDURE DisableBreak( ) : LONGINT ;
  15. BEGIN RETURN 0
  16. END DisableBreak ;
  17.  
  18. (* Gadget defines of our choosing, to be used as GadgetID's,    *)
  19. (* also used as the index into the gadget array my_gads[].    *)
  20.  
  21. CONST
  22.   MYGAD_SLIDER    = 0 ;
  23.   MYGAD_STRING1   = 1 ;
  24.   MYGAD_STRING2   = 2 ;
  25.   MYGAD_STRING3   = 3 ;
  26.   MYGAD_BUTTON    = 4 ;
  27.  
  28. (* Range for the slider: *)
  29.   SLIDER_MIN      =  1 ;
  30.   SLIDER_MAX      = 20 ;
  31.  
  32. VAR
  33.   Topaz80 : G.TextAttr ;
  34.  
  35. (* Print any error message.  We could do more fancy handling    *)
  36. (* (like an EasyRequest()), but this is only a demo.        *)
  37.  
  38. PROCEDURE errorMessage( error : STRING ) ;
  39. BEGIN IF error # NIL THEN D.Printf("Error: %s\n", error) END
  40. END errorMessage ;
  41.  
  42. (* Function to handle a GADGETUP or GADGETDOWN event.  For GadTools gadgets,  *)
  43. (* it is possible to use this function to handle MOUSEMOVEs as well, with     *)
  44. (* little or no work.                                  *)
  45.  
  46. PROCEDURE handleGadgetEvent( win  : I.WindowPtr ;
  47.                  gad  : I.GadgetPtr ;
  48.                  code : CARDINAL ;
  49.                  VAR slider_level : INTEGER ;
  50.                  VAR my_gads : ARRAY OF I.GadgetPtr ) ;
  51. BEGIN
  52.   CASE gad^.GadgetID OF
  53.   | MYGAD_SLIDER: (*Sliders report their level in the IntuiMessage Code field:*)
  54.     D.Printf( "Slider at level %ld\n", code ) ;
  55.                slider_level := code
  56.  
  57.   | MYGAD_STRING1: (* String gadgets report GADGETUP's *)
  58.  
  59.     D.Printf( "String gadget 1: '%s'.\n",
  60.                gad^.SpecialInfo(I.StringInfoPtr)^.Buffer )
  61.  
  62.   | MYGAD_STRING2: (* String gadgets report GADGETUP's *)
  63.  
  64.     D.Printf( "String gadget 2: '%s'.\n",
  65.                 gad^.SpecialInfo(I.StringInfoPtr)^.Buffer )
  66.  
  67.   | MYGAD_STRING3: (* String gadgets report GADGETUP's *)
  68.  
  69.     D.Printf( "String gadget 3: '%s'.\n",
  70.         gad^.SpecialInfo(I.StringInfoPtr)^.Buffer )
  71.  
  72.   | MYGAD_BUTTON: (* Buttons report GADGETUP's (button resets slider to 10) *)
  73.  
  74.     D.Printf("Button was pressed, slider reset to 10.\n");
  75.     slider_level := 10 ;
  76.     GT.GT_SetGadgetAttrs( my_gads[MYGAD_SLIDER], win, NIL,
  77.                           GT.GTSL_Level, slider_level,
  78.                           U.TAG_END )
  79.   ELSE
  80.   END
  81. END handleGadgetEvent ;
  82.  
  83.  
  84. (* Function to handle vanilla keys *)
  85.  
  86. PROCEDURE handleVanillaKey( win         : I.WindowPtr ;
  87.                 code     : CARDINAL ;
  88.                 VAR slider_level : INTEGER ;
  89.                 VAR my_gads     : ARRAY OF I.GadgetPtr ) ;
  90. BEGIN
  91.   CASE CHR( code ) OF
  92.  
  93.   | 'v': (* increase slider level, but not past maximum *)
  94.  
  95.          INC( slider_level ) ;
  96.          IF slider_level > SLIDER_MAX THEN slider_level := SLIDER_MAX END ;
  97.          GT.GT_SetGadgetAttrs( my_gads[MYGAD_SLIDER], win, NIL,
  98.                                GT.GTSL_Level, slider_level, U.TAG_END )
  99.  
  100.   | 'V': (* decrease slider level, but not past minimum *)
  101.  
  102.          DEC( slider_level ) ;
  103.          IF slider_level < SLIDER_MIN THEN slider_level := SLIDER_MIN END ;
  104.          GT.GT_SetGadgetAttrs( my_gads[MYGAD_SLIDER], win, NIL,
  105.                                GT.GTSL_Level, slider_level, U.TAG_END )
  106.  
  107.   | 'c','C': (* button resets slider to 10 *)
  108.  
  109.              slider_level := 10 ;
  110.              GT.GT_SetGadgetAttrs( my_gads[MYGAD_SLIDER], win, NIL,
  111.                                    GT.GTSL_Level, slider_level, U.TAG_END )
  112.  
  113.   |'f','F': I.ActivateGadget( my_gads[MYGAD_STRING1], win, NIL )
  114.   |'s','S': I.ActivateGadget( my_gads[MYGAD_STRING2], win, NIL )
  115.   |'t','T': I.ActivateGadget( my_gads[MYGAD_STRING3], win, NIL )
  116.   ELSE
  117.   END
  118. END handleVanillaKey ;
  119.  
  120.  
  121. (* Here is where all the initialization and creation of GadTools gadgets  *)
  122. (* take place.  This function requires a pointer to a NIL-initialized     *)
  123. (* gadget list pointer.  It returns a pointer to the last created gadget, *)
  124. (* which can be checked for success/failure.                  *)
  125.  
  126. PROCEDURE createAllGadgets( VAR glistptr     : I.GadgetPtr ;
  127.                 vi         : GT.VisualInfoPtr ;
  128.                         topborder    : CARDINAL ;
  129.                 slider_level : INTEGER ;
  130.                     VAR my_gads      : ARRAY OF I.GadgetPtr
  131.                   ) : I.GadgetPtr;
  132.   VAR
  133.     ng  : GT.NewGadget ;
  134.     gad : I.GadgetPtr ;
  135.  
  136. (* All the gadget creation calls accept a pointer to the previous gadget, and *)
  137. (* link the new gadget to that gadget's NextGadget field.  Also, they exit    *)
  138. (* gracefully, returning NIL, if any previous gadget was NIL.  This limits    *)
  139. (* the amount of checking for failure that is needed.  You only need to check *)
  140. (* before you tweak any gadget structure or use any of its fields,and finally *)
  141. (* once at the end, before you add the gadgets.                      *)
  142.  
  143. (* The following operation is required of any program that uses GadTools. *)
  144. (* It gives the toolkit a place to stuff context data.              *)
  145.  
  146. BEGIN
  147.   gad := GT.CreateContext( glistptr ) ;
  148.  
  149. (* Since the NewGadget structure is unmodified by any of the CreateGadget() *)
  150. (* calls, we need only change those fields which are different.            *)
  151.  
  152.   ng.ng_LeftEdge   := 140 ;
  153.   ng.ng_TopEdge    := 20+topborder ;
  154.   ng.ng_Width      := 200 ;
  155.   ng.ng_Height     := 12 ;
  156.   ng.ng_GadgetText := "_Volume:   " ;
  157.   ng.ng_TextAttr   := ADR( Topaz80 ) ;
  158.   ng.ng_VisualInfo := vi ;
  159.   ng.ng_GadgetID   := MYGAD_SLIDER ;
  160.   ng.ng_Flags      := GT.NG_HIGHLABEL ;
  161.  
  162.   gad := GT.CreateGadget( GT.SLIDER_KIND, gad, ng,
  163.               GT.GTSL_Min,         SLIDER_MIN,
  164.               GT.GTSL_Max,         SLIDER_MAX,
  165.               GT.GTSL_Level,       slider_level,
  166.               GT.GTSL_LevelFormat, "%2ld",
  167.               GT.GTSL_MaxLevelLen, 2,
  168.               GT.GT_Underscore,    '_',
  169.               U.TAG_END ) ;
  170.  
  171.   my_gads[MYGAD_SLIDER] := gad ;
  172.  
  173.   INC( ng.ng_TopEdge, 20 ) ;
  174.   ng.ng_Height     := 14 ;
  175.   ng.ng_GadgetText := "_First:" ;
  176.   ng.ng_GadgetID   := MYGAD_STRING1 ;
  177.  
  178.   gad := GT.CreateGadget( GT.STRING_KIND, gad, ng,
  179.               GT.GTST_String,   "Try pressing",
  180.               GT.GTST_MaxChars, 50,
  181.               GT.GT_Underscore, '_',
  182.               U.TAG_END ) ;
  183.  
  184.   my_gads[MYGAD_STRING1] := gad ;
  185.  
  186.   INC( ng.ng_TopEdge, 20 ) ;
  187.  
  188.   ng.ng_GadgetText := "_Second:" ;
  189.   ng.ng_GadgetID   := MYGAD_STRING2 ;
  190.  
  191.   gad := GT.CreateGadget( GT.STRING_KIND, gad, ng,
  192.               GT.GTST_String,   "TAB or Shift-TAB",
  193.               GT.GTST_MaxChars, 50,
  194.               GT.GT_Underscore, '_',
  195.               U.TAG_END ) ;
  196.  
  197.   my_gads[MYGAD_STRING2] := gad ;
  198.  
  199.   INC( ng.ng_TopEdge, 20 ) ;
  200.   ng.ng_GadgetText := "_Third:";
  201.   ng.ng_GadgetID   := MYGAD_STRING3;
  202.  
  203.   gad := GT.CreateGadget( GT.STRING_KIND, gad, ng,
  204.               GT.GTST_String,   "To see what happens!",
  205.               GT.GTST_MaxChars, 50,
  206.               GT.GT_Underscore, '_',
  207.               U.TAG_END ) ;
  208.  
  209.   my_gads[MYGAD_STRING3] := gad ;
  210.  
  211.   INC( ng.ng_LeftEdge, 50 );
  212.   INC( ng.ng_TopEdge, 20 ) ;
  213.   ng.ng_Width      := 100 ;
  214.   ng.ng_Height     := 12 ;
  215.   ng.ng_GadgetText := "_Click Here" ;
  216.   ng.ng_GadgetID   := MYGAD_BUTTON ;
  217.   ng.ng_Flags      := { } ;
  218.   gad := GT.CreateGadget( GT.BUTTON_KIND, gad, ng,
  219.                 GT.GT_Underscore, '_',
  220.                 U.TAG_END ) ;
  221.   RETURN gad
  222. END createAllGadgets ;
  223.  
  224.  
  225. (* Standard message handling loop with GadTools message handling functions *)
  226. (* used (GT_GetIMsg() and GT_ReplyIMsg()).                   *)
  227.  
  228. PROCEDURE process_window_events( mywin : I.WindowPtr ;
  229.                  slider_level : INTEGER ;
  230.                  VAR my_gads : ARRAY OF I.GadgetPtr ) ;
  231.  
  232.   VAR
  233.     imsg    : I.IntuiMessagePtr ;
  234.     imsgClass    : LONGSET ;
  235.     imsgCode    : CARDINAL ;
  236.     gad        : I.GadgetPtr ;
  237.     terminated    : BOOLEAN ;
  238.  
  239. BEGIN
  240.   terminated := FALSE ;
  241.  
  242.   WHILE ~terminated DO
  243.     E.Wait({mywin^.UserPort^.mp_SigBit}) ;
  244.  
  245.     (* GT_GetIMsg()returns an IntuiMessage with more friendly information for *)
  246.     (* complex gadget classes.  Use it wherever you get IntuiMessages where   *)
  247.     (* using GadTools gadgets.                              *)
  248.  
  249.     LOOP
  250.       IF terminated THEN EXIT END ;
  251.       imsg := GT.GT_GetIMsg( mywin^.UserPort ) ;
  252.       IF imsg = NIL THEN EXIT END ;
  253.  
  254.       (* Presuming a gadget, of course, but no harm...            *)
  255.       (* Only dereference this value (gad) where the Class specifies    *)
  256.       (* that it is a gadget event.                    *)
  257.  
  258.       gad := imsg^.IAddress;
  259.  
  260.       imsgClass := imsg^.Class ;
  261.       imsgCode := imsg^.Code ;
  262.  
  263.       (* Use the toolkit message-replying function here... *)
  264.       GT.GT_ReplyIMsg( imsg ) ;
  265.  
  266.       (* GadTools puts the gadget address into IAddress of IDCMP_MOUSEMOVE   *)
  267.       (* messages.  This is NOT true for standard Intuition messages,         *)
  268.       (* but is an added feature of GadTools.                     *)
  269.  
  270.       IF imsgClass <= I.IDCMP_GADGETDOWN+I.IDCMP_MOUSEMOVE+I.IDCMP_GADGETUP THEN
  271.     handleGadgetEvent( mywin, gad, imsgCode, slider_level, my_gads )
  272.  
  273.       ELSIF imsgClass = I.IDCMP_VANILLAKEY THEN
  274.     handleVanillaKey( mywin, imsgCode, slider_level, my_gads )
  275.  
  276.       ELSIF imsgClass = I.IDCMP_CLOSEWINDOW THEN
  277.         terminated := TRUE
  278.  
  279.       ELSIF imsgClass = I.IDCMP_REFRESHWINDOW THEN
  280.  
  281.     (* With GadTools, the application must use GT_BeginRefresh() *)
  282.     (* where it would normally have used BeginRefresh()         *)
  283.  
  284.     GT.GT_BeginRefresh( mywin ) ;
  285.     GT.GT_EndRefresh( mywin , TRUE )
  286.       ELSE HALT
  287.       END
  288.     END
  289.   END
  290. END process_window_events ;
  291.  
  292.  
  293. (* Prepare for using GadTools, set up gadgets and open window.    *)
  294. (* Clean up and when done or on error.                *)
  295.  
  296. PROCEDURE gadtoolsWindow( ) ;
  297.  
  298.   CONST
  299.     winIDCMP = I.IDCMP_CLOSEWINDOW + I.IDCMP_REFRESHWINDOW+I.IDCMP_VANILLAKEY
  300.                +GT.SLIDERIDCMP+GT.STRINGIDCMP+GT.BUTTONIDCMP ;
  301.   VAR
  302.     font     : G.TextFontPtr ;
  303.     mysc     : I.ScreenPtr ;
  304.     mywin     : I.WindowPtr ;
  305.     glist     : I.GadgetPtr ;
  306.     my_gads     : ARRAY [0..3] OF I.GadgetPtr ;
  307.     vi             : GT.VisualInfoPtr ;
  308.     slider_level : INTEGER ;
  309.     topborder    : CARDINAL ;
  310.  
  311. (* Open topaz 8 font, so we can be sure it's openable    *)
  312. (* when we later set ng_TextAttr to &Topaz80:        *)
  313.  
  314. BEGIN
  315.   slider_level := 5 ;
  316.   font := G.OpenFont( ADR( Topaz80 ) ) ;
  317.   IF font = NIL THEN errorMessage( "Failed to open Topaz 80")
  318.   ELSE mysc := I.LockPubScreen( NIL ) ;
  319.     IF mysc = NIL THEN errorMessage( "Couldn't lock default public screen")
  320.     ELSE
  321.       vi := GT.GetVisualInfo( mysc, U.TAG_END ) ;
  322.       IF vi = NIL THEN errorMessage( "GetVisualInfo() failed")
  323.       ELSE
  324.         (* Here is how we can figure out ahead of time how tall the  *)
  325.         (* window's title bar will be:                               *)
  326.         topborder := mysc^.WBorTop + (mysc^.Font^.ta_YSize + 1) ;
  327.  
  328.         IF createAllGadgets( glist,vi,topborder,slider_level,my_gads) = NIL THEN
  329.           errorMessage( "createAllGadgets() failed")
  330.         ELSE
  331.           mywin := I.OpenWindowTags( NIL,
  332.                      I.WA_Title,     "GadTools Gadget Demo",
  333.                      I.WA_Gadgets,     glist,
  334.                      I.WA_AutoAdjust,     TRUE,
  335.                      I.WA_Width,     400,
  336.                      I.WA_MinWidth,     50,
  337.                      I.WA_InnerHeight,     140,
  338.                      I.WA_MinHeight,     50,
  339.                      I.WA_DragBar,     TRUE,
  340.                      I.WA_DepthGadget,     TRUE,
  341.                      I.WA_Activate,     TRUE,
  342.                      I.WA_CloseGadget,     TRUE,
  343.                      I.WA_SizeGadget,     TRUE,
  344.                      I.WA_SimpleRefresh, TRUE,
  345.                      I.WA_IDCMP,     winIDCMP,
  346.                      I.WA_PubScreen,     mysc,
  347.                      U.TAG_END ) ;
  348.  
  349.           IF mywin = NIL THEN errorMessage( "OpenWindow() failed")
  350.           ELSE
  351.             (* After window is open, gadgets must be refreshed with a *)
  352.             (* call to the GadTools refresh window function.          *)
  353.  
  354.             GT.GT_RefreshWindow( mywin, NIL ) ;
  355.         process_window_events( mywin, slider_level, my_gads ) ;
  356.         I.CloseWindow( mywin )
  357.           END
  358.         END ;
  359.         (* FreeGadgets() even if createAllGadgets() fails, as some  *)
  360.         (* of the gadgets may have been created...If glist is NIL   *)
  361.         (* then FreeGadgets() will do nothing.                *)
  362.  
  363.         GT.FreeGadgets( glist ) ;
  364.         GT.FreeVisualInfo( vi )
  365.       END ;
  366.       I.UnlockPubScreen( NIL, mysc )
  367.     END ;
  368.     G.CloseFont( font )
  369.   END
  370. END gadtoolsWindow ;
  371.  
  372. BEGIN
  373.   SL.onbreak( DisableBreak ) ;
  374.   Topaz80 := ["topaz.font",8] ;
  375.   gadtoolsWindow( ) ;
  376. END GadToolsGadgets.
  377.