home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 9 / FreshFishVol9-CD1.bin / useful / dev / obero / oberon-a / examples / libraries / intuition / rkmbuttonclass.mod < prev    next >
Encoding:
Text File  |  1995-01-25  |  17.0 KB  |  531 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: RKMButtonclass.mod $
  4.   Description: Example Boopsi gadget for RKRM:Libraries
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 1.3 $
  8.       $Author: fjc $
  9.         $Date: 1995/01/25 23:52:19 $
  10.  
  11.   Copyright © 1994-1995, Frank Copeland.
  12.   This example program is part of Oberon-A.
  13.   See Oberon-A.doc for conditions of use and distribution.
  14.  
  15.   Log entries are at the end of the file.
  16.  
  17. *************************************************************************)
  18.  
  19. <* STANDARD- *> <*$ NilChk- StackChk- *>
  20.  
  21. MODULE RKMButtonclass;
  22.  
  23. IMPORT
  24.   SYS := SYSTEM,
  25.   Kernel,
  26.   e   := Exec,
  27.   i   := Intuition,
  28.   u   := Utility,
  29.   gfx := Graphics,
  30.   cf  := ClassFace,
  31.   hu  := HookUtil,
  32.   IE  := InputEvent,
  33.   Errors,
  34.   d   := Dos;
  35.  
  36. CONST
  37.   VersionTag = "$VER: RKMButtonclass 1.3 (24.1.95)\r\n";
  38.   VersionStr = "RKMButtonclass 1.3 (24.1.95)\r\n";
  39.   CopyrightStr = "Copyright © 1994-1995 Frank Copeland";
  40.  
  41. (*
  42. ** Class specifics
  43. *)
  44.  
  45. CONST
  46.  
  47.   rkmButPulse = u.user + 1;
  48.  
  49. TYPE
  50.  
  51.   ButINSTPtr = POINTER [2] TO ButINST;
  52.   ButINST = RECORD [2]
  53.     midX, midY : LONGINT; (* Co-ordinates of middle of gadget *)
  54.   END;
  55.  
  56. CONST
  57.  
  58. (* ButINST has one flag: *)
  59.  
  60.   eraseOnly = 0; (* Tells rendering routine to *)
  61.                  (* only erase the gadget, not *)
  62.                  (* rerender a new one.  This  *)
  63.                  (* lets the gadget erase it-  *)
  64.                  (* self before it rescales.   *)
  65.  
  66. (**************************************************************************)
  67. (* The Main procedure connects an RKMButClass object to a Boopsi integer  *)
  68. (* gadget, which displays the RKMButClass gadget's rkmButPulse value.     *)
  69. (* The code scales and moves the gadget while it is in place.             *)
  70. (**************************************************************************)
  71.  
  72. VAR
  73.  
  74.   pulse2int : ARRAY 2 OF u.TagItem;
  75.  
  76. CONST
  77.  
  78.   intWidth = 40;
  79.   intHeight = 20;
  80.  
  81. VAR
  82.  
  83.   w : i.WindowPtr;
  84.   rkmbutcl : i.IClassPtr;
  85.   integer, but : i.GadgetPtr;
  86.   msg : i.IntuiMessagePtr;
  87.  
  88. (*------------------------------------*)
  89. PROCEDURE^ freeRKMButGadClass ( cl : i.IClassPtr );
  90.  
  91. PROCEDURE* Cleanup (VAR rc : LONGINT);
  92. BEGIN (* Cleanup *)
  93.   IF but # NIL THEN
  94.     SYS.PUTREG (0, i.RemoveGList (w, integer, -1));
  95.     i.DisposeObject (but); but := NIL
  96.   END;
  97.   IF integer # NIL THEN i.DisposeObject (integer); integer := NIL END;
  98.   IF rkmbutcl # NIL THEN freeRKMButGadClass (rkmbutcl); rkmbutcl := NIL END;
  99.   IF w # NIL THEN i.CloseWindow (w); w := NIL END
  100. END Cleanup;
  101.  
  102. (*------------------------------------*)
  103. PROCEDURE Init ();
  104.  
  105. BEGIN (* Init *)
  106.   ASSERT (u.base # NIL, 100);
  107.   pulse2int [0].tag := rkmButPulse; pulse2int [0].data := i.stringaLongVal;
  108.   pulse2int [1].tag := u.end;
  109.   but := NIL; integer := NIL; rkmbutcl := NIL; w := NIL;
  110.   Kernel.SetCleanup (Cleanup)
  111. END Init;
  112.  
  113.  
  114. (*------------------------------------*)
  115. PROCEDURE MainLoop ( attr, value : LONGINT );
  116.  
  117.   VAR done : BOOLEAN; ignore : LONGINT;
  118.  
  119. BEGIN (* MainLoop *)
  120.   done := FALSE;
  121.   ignore := i.SetGadgetAttrs (but^, w, NIL, attr, value, u.done);
  122.   WHILE ~done DO
  123.     e.WaitPort (w.userPort);
  124.     LOOP
  125.       msg := SYS.VAL (i.IntuiMessagePtr, e.GetMsg (w.userPort));
  126.       IF msg = NIL THEN EXIT END;
  127.       IF msg.class = {i.closeWindow} THEN done := TRUE END;
  128.       e.ReplyMsg (msg)
  129.     END;
  130.   END;
  131. END MainLoop;
  132.  
  133. (*------------------------------------*)
  134. PROCEDURE RenderRKMBut
  135.   ( cl : i.IClassPtr; g : i.GadgetPtr; msg : i.RenderPtr )
  136.   : e.APTR;
  137.  
  138.   VAR
  139.     inst : ButINSTPtr;
  140.     rp : gfx.RastPortPtr;
  141.     retval : e.APTR;
  142.     pens : i.DRIPenArrayPtr;
  143.     back, shine, shadow, wd, h, x, y : INTEGER;
  144.  
  145. BEGIN (* RenderRKMBut *)
  146.   inst := cf.InstData (cl, SYS.VAL (i.ObjectPtr, g));
  147.   retval := SYS.VAL (e.APTR, e.LTRUE);
  148.   pens := msg.gInfo.drInfo.pens;
  149.   IF msg.msg.methodID = i.gmRender THEN (* If msg is truly a gmRender message *)
  150.                                     (* (not a Input that looks like a     *)
  151.                                     (* Render), use the rastport within   *)
  152.                                     (* it...                              *)
  153.     rp := msg.rPort
  154.   ELSE                              (* ...Otherwise, get a rastport using *)
  155.                                     (* ObtainGIRPort().                   *)
  156.     rp := i.ObtainGIRPort (msg.gInfo)
  157.   END;
  158.   IF rp # NIL THEN
  159.     IF i.selected IN g.flags THEN      (* If the gadget is selected,  *)
  160.                                        (* reverse the meanings of the *)
  161.                                        (* pens.                       *)
  162.       back := pens [i.fillPen];
  163.       shine := pens [i.shadowPen];
  164.       shadow := pens [i.shinePen]
  165.     ELSE
  166.       back := pens [i.backGroundPen];
  167.       shine := pens [i.shinePen];
  168.       shadow := pens [i.shadowPen]
  169.     END;
  170.     gfx.SetDrMd (rp, gfx.jam1);
  171.  
  172.     gfx.SetAPen (rp, SHORT (back));          (* Erase the old gadget *)
  173.     gfx.RectFill
  174.       ( rp, g.leftEdge,
  175.             g.topEdge,
  176.             g.leftEdge + g.width,
  177.             g.topEdge + g.height );
  178.  
  179.     gfx.SetAPen (rp, SHORT (shadow));            (* Draw shadow edge *)
  180.     gfx.Move (rp, g.leftEdge + 1, g.topEdge + g.height);
  181.     gfx.Draw (rp, g.leftEdge + g.width, g.topEdge + g.height);
  182.     gfx.Draw (rp, g.leftEdge + g.width, g.topEdge + 1);
  183.  
  184.     wd := g.width DIV 4;         (* Draw arrows - Sorry, no frills imagery *)
  185.     h := g.height DIV 2;
  186.     x := g.leftEdge + (wd DIV 2);
  187.     y := g.topEdge + (h DIV 2);
  188.  
  189.     gfx.Move (rp, x, SHORT (inst.midY));
  190.     gfx.Draw (rp, x + wd, y);
  191.     gfx.Draw (rp, x + wd, y + g.height - h);
  192.     gfx.Draw (rp, x, SHORT (inst.midY));
  193.  
  194.     x := g.leftEdge + (wd DIV 2) + g.width DIV 2;
  195.  
  196.     gfx.Move (rp, x + wd, SHORT (inst.midY));
  197.     gfx.Draw (rp, x, y);
  198.     gfx.Draw (rp, x, y + g.height - h);
  199.     gfx.Draw (rp, x + wd, SHORT (inst.midY));
  200.  
  201.     gfx.SetAPen (rp, SHORT (shine));              (* Draw shine edge *)
  202.     gfx.Move (rp, g.leftEdge, g.topEdge + g.height - 1);
  203.     gfx.Draw (rp, g.leftEdge, g.topEdge);
  204.     gfx.Draw (rp, g.leftEdge + g.width - 1, g.topEdge);
  205.  
  206.     IF msg.msg.methodID # i.gmRender THEN (* If we allocated a rastport, give *)
  207.                                       (* it back. *)
  208.       i.ReleaseGIRPort (rp)
  209.     END;
  210.   ELSE
  211.     retval := SYS.VAL (e.APTR, e.LFALSE);
  212.   END;
  213.   RETURN retval
  214. END RenderRKMBut;
  215.  
  216.  
  217. (*------------------------------------*)
  218. PROCEDURE NotifyPulse
  219.   ( cl    : i.IClassPtr;
  220.     o     : i.ObjectPtr;
  221.     flags : SET;
  222.     mid   : LONGINT;
  223.     gpi   : i.InputPtr );
  224.  
  225.   VAR
  226.     tt : ARRAY 3 OF u.TagItem;
  227.     g : i.GadgetPtr;
  228.     ignore : e.APTR;
  229.  
  230. BEGIN (* NotifyPulse *)
  231.   g := SYS.VAL (i.GadgetPtr, o);
  232.  
  233.   tt[0].tag := rkmButPulse;
  234.   tt[0].data := mid - gpi.mouse.x + g.leftEdge;
  235.  
  236.   tt[1].tag := i.gaID;
  237.   tt[1].data := g.gadgetID;
  238.  
  239.   tt[2].tag := u.done;
  240.  
  241.   ignore := cf.DoSuperMethod
  242.     (cl, o, i.omNotify, SYS.ADR (tt), gpi.gInfo, flags)
  243. END NotifyPulse;
  244.  
  245. (*------------------------------------*)
  246. PROCEDURE* dispatchRKMButGad
  247.   ( hook : u.HookPtr; obj : e.APTR; message : e.APTR )
  248.   : e.APTR;
  249.  
  250.   VAR
  251.     cl : i.IClassPtr; o : i.ObjectPtr; msg : i.MsgPtr;
  252.     inst : ButINSTPtr;
  253.     retval, ignore : SYS.LONGWORD;
  254.     object : i.ObjectPtr;
  255.     g : i.GadgetPtr;
  256.     gpi : i.InputPtr;
  257.     ie : IE.InputEventPtr;
  258.     rp : gfx.RastPortPtr;
  259.     x, y, wd, h : INTEGER;
  260.     pens : i.DRIPenArrayPtr;
  261.     opSet : i.OpSetPtr;
  262.  
  263. <*$SaveRegs+*>
  264. BEGIN (* dispatchRKMButGad *)
  265.   cl := SYS.VAL (i.IClassPtr, hook);
  266.   o := obj;
  267.   msg := message;
  268.   retval := e.LTRUE;
  269.   CASE msg.methodID OF
  270.     i.omNew : (* First, pass up to superclass *)
  271.       object := cf.DoSuperMethodA (cl, o, msg^);
  272.       IF object # NIL THEN
  273.         g := SYS.VAL (i.GadgetPtr, object);
  274.                 (* Initial local instance data *)
  275.         inst := cf.InstData (cl, object);
  276.         inst.midX := g.leftEdge + (g.width DIV 2);
  277.         inst.midY := g.topEdge + (g.height DIV 2);
  278.         retval := object
  279.       END;
  280.     |
  281.     i.gmHitTest :
  282.           (* Since this is a rectangular gadget this *)
  283.           (* method always returns i.gmrGadgetHit.   *)
  284.       retval := i.gmrGadgetHit;
  285.     |
  286.     i.gmGoActive :
  287.       inst := cf.InstData (cl, o);
  288.           (* Only become active if the gmGoActive *)
  289.           (* was triggered by direct user input.  *)
  290.       gpi := SYS.VAL (i.InputPtr, msg);
  291.       IF gpi.iEvent # NIL THEN
  292.             (* This gadget is now active, change    *)
  293.             (* visual state to selected and render. *)
  294.         g := SYS.VAL (i.GadgetPtr, o);
  295.         INCL (g.flags, i.selected);
  296.         ignore := RenderRKMBut (cl, g, SYS.VAL (i.RenderPtr, msg));
  297.         retval := i.gmrMeActive
  298.       ELSE    (* The gmGoActive was not         *)
  299.               (* triggered by direct user input *)
  300.         retval := i.gmrNoReuse
  301.       END;
  302.     |
  303.     i.gmRender :
  304.       g := SYS.VAL (i.GadgetPtr, o);
  305.       retval := RenderRKMBut (cl, g, SYS.VAL (i.RenderPtr, msg));
  306.     |
  307.     i.gmHandleInput : (* While it is active, this gadget sends its      *)
  308.                       (* superclass an omNotify pulse for every         *)
  309.                       (* classTimer event that goes by (about one every *)
  310.                       (* 10th of a second).  Any object that is         *)
  311.                       (* connected to this gadget will get A LOT of     *)
  312.                       (* omUpdate messages.                             *)
  313.       g := SYS.VAL (i.GadgetPtr, o);
  314.       gpi := SYS.VAL (i.InputPtr, msg);
  315.       ie := SYS.VAL (IE.InputEventPtr, gpi.iEvent);
  316.  
  317.       inst := cf.InstData (cl, o);
  318.  
  319.       retval := i.gmrMeActive;
  320.  
  321.       IF ie.class = IE.rawmouse THEN
  322.         CASE ie.code OF
  323.           i.selectUp :  (* The user let go of the gadget so return       *)
  324.                         (* gmrNoReuse to deactivate and to tell          *)
  325.                         (* Intuition not to reuse this Input Event as we *)
  326.                         (* have already processed it.                    *)
  327.  
  328.                         (* If the user let go of the gadget while the    *)
  329.                         (* mouse was over it, mask gmrVerify into the    *)
  330.                         (* return value so Intuition will send a Release *)
  331.                         (* Verify (gadgetUp).                            *)
  332.             IF
  333.               (gpi.mouse.x < g.leftEdge) OR
  334.               (gpi.mouse.x > g.leftEdge + g.width) OR
  335.               (gpi.mouse.y < g.topEdge) OR
  336.               (gpi.mouse.y > g.topEdge + g.height)
  337.             THEN
  338.               retval := i.gmrNoReuse + i.gmrVerify
  339.             ELSE
  340.               retval := i.gmrNoReuse
  341.             END;
  342.  
  343.                      (* Since the gadget is going inactive, send a final *)
  344.                      (* notification to the icaTarget                    *)
  345.             NotifyPulse (cl, o, {}, inst.midX, gpi)
  346.           |
  347.           i.menuDown :  (* The user hit the menu button. Go inactive and *)
  348.                         (* let Intuition reuse the menu button event so  *)
  349.                         (* Intuition can pop up the menu bar.            *)
  350.             retval := i.gmrReuse;
  351.             NotifyPulse (cl, o, {}, inst.midX, gpi)
  352.           |
  353.         ELSE
  354.           retval := i.gmrMeActive
  355.         END
  356.       ELSIF ie.class = IE.timer THEN
  357.             (* If the gadget gets a timer event, it sends an interim *)
  358.             (* omNotify to its superclass.                           *)
  359.         NotifyPulse (cl, o, {i.opuInterim}, inst.midX, gpi)
  360.       END;
  361.     |
  362.     i.gmGoInactive :      (* Intuition said to go inactive.  Clear the    *)
  363.                           (* gflgSelected bit and render using unselected *)
  364.                           (* imagery.                                     *)
  365.       g := SYS.VAL (i.GadgetPtr, o);
  366.       EXCL (g.flags, i.selected);
  367.       ignore := RenderRKMBut (cl, g, SYS.VAL (i.RenderPtr, msg));
  368.     |
  369.     i.omSet :    (* Although this class doesn't have settable attributes, *)
  370.                  (* this gadget class does have scaleable imagery, so it  *)
  371.                  (* needs to find out when its size and/or position has   *)
  372.                  (* changed so it can erase itself, THEN scale, and       *)
  373.                  (* rerender.                                             *)
  374.       opSet := SYS.VAL (i.OpSetPtr, msg);
  375.       IF
  376.         (u.FindTagItem (i.gaWidth, opSet.attrList) # NIL) OR
  377.         (u.FindTagItem (i.gaHeight, opSet.attrList) # NIL) OR
  378.         (u.FindTagItem (i.gaTop, opSet.attrList) # NIL) OR
  379.         (u.FindTagItem (i.gaLeft, opSet.attrList) # NIL)
  380.       THEN
  381.         g := SYS.VAL (i.GadgetPtr, o);
  382.  
  383.         x := g.leftEdge;
  384.         y := g.topEdge;
  385.         wd := g.width;
  386.         h := g.height;
  387.  
  388.         inst := cf.InstData (cl, o);
  389.  
  390.         retval := cf.DoSuperMethodA (cl, o, msg^);
  391.  
  392.                                     (* Get pointer to RastPort for gadget *)
  393.         rp := i.ObtainGIRPort (opSet.gInfo);
  394.         IF rp # NIL THEN
  395.           pens := opSet.gInfo.drInfo.pens;
  396.           gfx.SetAPen (rp, SHORT (pens [i.backGroundPen]));
  397.           gfx.SetDrMd (rp, gfx.jam1);       (* Erase the old gadget. *)
  398.           gfx.RectFill (rp, x, y, x+wd, y+h);
  399.  
  400.           inst.midX := g.leftEdge + (g.width DIV 2); (* Recalculate where *)
  401.           inst.midY := g.topEdge + (g.height DIV 2); (* the center of the *)
  402.                                                      (* gadget is. *)
  403.  
  404.                                                   (* Rerender the gadget. *)
  405.           ignore :=
  406.             cf.DoMethod (o, i.gmRender, opSet.gInfo, rp, i.gRedrawRedraw);
  407.           i.ReleaseGIRPort (rp)
  408.         END;
  409.       ELSE
  410.         retval := cf.DoSuperMethodA (cl, o, msg^)
  411.       END;
  412.     |
  413.   ELSE (* rkmbutgadclass does not recognize the methodId, let the *)
  414.        (* superclass's dispatcher take a look at it. *)
  415.     retval := cf.DoSuperMethodA (cl, o, msg^);
  416.   END;
  417.   RETURN SYS.VAL (e.APTR, retval)
  418. END dispatchRKMButGad;
  419.  
  420. (*------------------------------------*)
  421. PROCEDURE initRKMButGadClass () : i.IClassPtr;
  422.  
  423.   VAR
  424.     cl : i.IClassPtr;
  425.  
  426. BEGIN (* initRKMButGadClass *)
  427.   cl := i.MakeClass ( "", "gadgetclass", NIL, SIZE (ButINST), {} );
  428.   IF cl # NIL THEN
  429.     (* initialize the IClass Hook *)
  430.     cl.dispatcher.entry := hu.HookEntry;
  431.     cl.dispatcher.subEntry := dispatchRKMButGad;
  432.   END;
  433.   RETURN cl
  434. END initRKMButGadClass;
  435.  
  436.  
  437. (*------------------------------------*)
  438. PROCEDURE freeRKMButGadClass ( cl : i.IClassPtr );
  439.  
  440.   VAR ignore : BOOLEAN;
  441.  
  442. BEGIN (* freeRKMButGadClass *)
  443.   ignore := i.FreeClass (cl)
  444. END freeRKMButGadClass;
  445.  
  446. (*------------------------------------*)
  447. PROCEDURE Main ();
  448.  
  449.   VAR ignore : INTEGER;
  450.  
  451. BEGIN (* Main *)
  452.   IF i.base.libNode.version >= 37 THEN
  453.     IF u.base.libNode.version >= 37 THEN
  454.       IF gfx.base.libNode.version >= 37 THEN
  455.         w := i.OpenWindowTagsA
  456.           ( NIL,
  457.             i.waFlags,  { i.windowDepth, i.windowDrag,
  458.                           i.windowClose, i.windowSizing },
  459.             i.waIDCMP,  {i.closeWindow},
  460.             i.waWidth,  640,
  461.             i.waHeight, 200,
  462.             u.end );
  463.         IF w # NIL THEN
  464.           IF i.WindowLimits (w, 450, 200, 640, 200) THEN END;
  465.           rkmbutcl := initRKMButGadClass();
  466.           IF rkmbutcl # NIL THEN
  467.             integer := i.NewObject
  468.               ( NIL, "strgclass",
  469.                 i.gaID,            1,
  470.                 i.gaTop,           LONG (w.borderTop) + 5,
  471.                 i.gaLeft,          LONG (w.borderLeft) + 5,
  472.                 i.gaWidth,         intWidth,
  473.                 i.gaHeight,        intHeight,
  474.                 i.stringaLongVal,  0,
  475.                 i.stringaMaxChars, 5,
  476.                 u.end );
  477.             IF integer # NIL THEN
  478.               but := i.NewObject
  479.                 ( rkmbutcl, "",
  480.                   i.gaID,            2,
  481.                   i.gaTop,           LONG (w.borderTop) + 5,
  482.                   i.gaLeft,          integer.leftEdge + integer.width + 5,
  483.                   i.gaWidth,         40,
  484.                   i.gaHeight,        intHeight,
  485.                   i.gaPrevious,      integer,
  486.                   i.icaMap,          SYS.ADR (pulse2int),
  487.                   i.icaTarget,       integer,
  488.                   u.end );
  489.               IF but # NIL THEN
  490.                 ignore := i.AddGList (w, integer, -1, -1, NIL);
  491.                 i.RefreshGList (integer, w, NIL, -1);
  492.  
  493.                 i.SetWindowTitles
  494.                   ( w, SYS.ADR ("<-- Click to resize gadget Height"), NIL );
  495.                 MainLoop (u.done, 0);
  496.  
  497.                 i.SetWindowTitles
  498.                   ( w, SYS.ADR ("<-- Click to resize gadget Width"), NIL );
  499.                 MainLoop (i.gaHeight, 100);
  500.  
  501.                 i.SetWindowTitles
  502.                   ( w, SYS.ADR ("<-- Click to resize gadget Y position"), NIL );
  503.                 MainLoop (i.gaWidth, 100);
  504.  
  505.                 i.SetWindowTitles
  506.                   ( w, SYS.ADR ("<-- Click to resize gadget X position"), NIL );
  507.                 MainLoop (i.gaTop, but.topEdge + 20);
  508.  
  509.                 i.SetWindowTitles
  510.                   ( w, SYS.ADR ("<-- Click to quit"), NIL );
  511.                 MainLoop (i.gaLeft, but.leftEdge + 20);
  512.  
  513.                 ignore := i.RemoveGList (w, integer, -1);
  514.                 i.DisposeObject (but); but := NIL
  515.               END;
  516.               i.DisposeObject (integer); integer := NIL
  517.             END;
  518.             freeRKMButGadClass (rkmbutcl); rkmbutcl := NIL
  519.           END;
  520.           i.CloseWindow (w); w := NIL
  521.         END;
  522.       END;
  523.     END;
  524.   END
  525. END Main;
  526.  
  527. BEGIN (* RKMButtonclass *)
  528.   Init ();
  529.   Main ();
  530. END RKMButtonclass.
  531.