home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 10 / Fresh_Fish_10_2352.bin / new / dev / obero / oberon-a / examples / libraries / intuition / rkmbuttonclass.mod < prev    next >
Text File  |  1995-07-02  |  17KB  |  529 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.4 $
  8.       $Author: fjc $
  9.         $Date: 1995/07/02 16:59:58 $
  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.   IE  := InputEvent,
  32.   Errors,
  33.   d   := Dos;
  34.  
  35. CONST
  36.   VersionTag = "$VER: RKMButtonclass 1.4 (4.6.95)\r\n";
  37.   VersionStr = "RKMButtonclass 1.4 (4.6.95)\r\n";
  38.   CopyrightStr = "Copyright © 1994-1995 Frank Copeland";
  39.  
  40. (*
  41. ** Class specifics
  42. *)
  43.  
  44. CONST
  45.  
  46.   rkmButPulse = u.user + 1;
  47.  
  48. TYPE
  49.  
  50.   ButINSTPtr = POINTER [2] TO ButINST;
  51.   ButINST = RECORD [2]
  52.     midX, midY : LONGINT; (* Co-ordinates of middle of gadget *)
  53.   END;
  54.  
  55. CONST
  56.  
  57. (* ButINST has one flag: *)
  58.  
  59.   eraseOnly = 0; (* Tells rendering routine to *)
  60.                  (* only erase the gadget, not *)
  61.                  (* rerender a new one.  This  *)
  62.                  (* lets the gadget erase it-  *)
  63.                  (* self before it rescales.   *)
  64.  
  65. (**************************************************************************)
  66. (* The Main procedure connects an RKMButClass object to a Boopsi integer  *)
  67. (* gadget, which displays the RKMButClass gadget's rkmButPulse value.     *)
  68. (* The code scales and moves the gadget while it is in place.             *)
  69. (**************************************************************************)
  70.  
  71. VAR
  72.  
  73.   pulse2int : ARRAY 2 OF u.TagItem;
  74.  
  75. CONST
  76.  
  77.   intWidth = 40;
  78.   intHeight = 20;
  79.  
  80. VAR
  81.  
  82.   w : i.WindowPtr;
  83.   rkmbutcl : i.IClassPtr;
  84.   integer, but : i.GadgetPtr;
  85.   msg : i.IntuiMessagePtr;
  86.  
  87. (*------------------------------------*)
  88. PROCEDURE^ freeRKMButGadClass ( cl : i.IClassPtr );
  89.  
  90. PROCEDURE* Cleanup (VAR rc : LONGINT);
  91. BEGIN (* Cleanup *)
  92.   IF but # NIL THEN
  93.     SYS.PUTREG (0, i.RemoveGList (w, integer, -1));
  94.     i.DisposeObject (but); but := NIL
  95.   END;
  96.   IF integer # NIL THEN i.DisposeObject (integer); integer := NIL END;
  97.   IF rkmbutcl # NIL THEN freeRKMButGadClass (rkmbutcl); rkmbutcl := NIL END;
  98.   IF w # NIL THEN i.CloseWindow (w); w := NIL END
  99. END Cleanup;
  100.  
  101. (*------------------------------------*)
  102. PROCEDURE Init ();
  103.  
  104. BEGIN (* Init *)
  105.   ASSERT (u.base # NIL, 100);
  106.   pulse2int [0].tag := rkmButPulse; pulse2int [0].data := i.stringaLongVal;
  107.   pulse2int [1].tag := u.end;
  108.   but := NIL; integer := NIL; rkmbutcl := NIL; w := NIL;
  109.   Kernel.SetCleanup (Cleanup)
  110. END Init;
  111.  
  112.  
  113. (*------------------------------------*)
  114. PROCEDURE MainLoop ( attr, value : LONGINT );
  115.  
  116.   VAR done : BOOLEAN; ignore : LONGINT;
  117.  
  118. BEGIN (* MainLoop *)
  119.   done := FALSE;
  120.   ignore := i.SetGadgetAttrs (but^, w, NIL, attr, value, u.done);
  121.   WHILE ~done DO
  122.     e.WaitPort (w.userPort);
  123.     LOOP
  124.       msg := SYS.VAL (i.IntuiMessagePtr, e.GetMsg (w.userPort));
  125.       IF msg = NIL THEN EXIT END;
  126.       IF msg.class = {i.closeWindow} THEN done := TRUE END;
  127.       e.ReplyMsg (msg)
  128.     END;
  129.   END;
  130. END MainLoop;
  131.  
  132. (*------------------------------------*)
  133. PROCEDURE RenderRKMBut
  134.   ( cl : i.IClassPtr; g : i.GadgetPtr; msg : i.RenderPtr )
  135.   : e.APTR;
  136.  
  137.   VAR
  138.     inst : ButINSTPtr;
  139.     rp : gfx.RastPortPtr;
  140.     retval : e.APTR;
  141.     pens : i.DRIPenArrayPtr;
  142.     back, shine, shadow, wd, h, x, y : INTEGER;
  143.  
  144. BEGIN (* RenderRKMBut *)
  145.   inst := cf.InstData (cl, SYS.VAL (i.ObjectPtr, g));
  146.   retval := SYS.VAL (e.APTR, e.LTRUE);
  147.   pens := msg.gInfo.drInfo.pens;
  148.   IF msg.msg.methodID = i.gmRender THEN (* If msg is truly a gmRender message *)
  149.                                     (* (not a Input that looks like a     *)
  150.                                     (* Render), use the rastport within   *)
  151.                                     (* it...                              *)
  152.     rp := msg.rPort
  153.   ELSE                              (* ...Otherwise, get a rastport using *)
  154.                                     (* ObtainGIRPort().                   *)
  155.     rp := i.ObtainGIRPort (msg.gInfo)
  156.   END;
  157.   IF rp # NIL THEN
  158.     IF i.selected IN g.flags THEN      (* If the gadget is selected,  *)
  159.                                        (* reverse the meanings of the *)
  160.                                        (* pens.                       *)
  161.       back := pens [i.fillPen];
  162.       shine := pens [i.shadowPen];
  163.       shadow := pens [i.shinePen]
  164.     ELSE
  165.       back := pens [i.backGroundPen];
  166.       shine := pens [i.shinePen];
  167.       shadow := pens [i.shadowPen]
  168.     END;
  169.     gfx.SetDrMd (rp, gfx.jam1);
  170.  
  171.     gfx.SetAPen (rp, SHORT (back));          (* Erase the old gadget *)
  172.     gfx.RectFill
  173.       ( rp, g.leftEdge,
  174.             g.topEdge,
  175.             g.leftEdge + g.width,
  176.             g.topEdge + g.height );
  177.  
  178.     gfx.SetAPen (rp, SHORT (shadow));            (* Draw shadow edge *)
  179.     gfx.Move (rp, g.leftEdge + 1, g.topEdge + g.height);
  180.     gfx.Draw (rp, g.leftEdge + g.width, g.topEdge + g.height);
  181.     gfx.Draw (rp, g.leftEdge + g.width, g.topEdge + 1);
  182.  
  183.     wd := g.width DIV 4;         (* Draw arrows - Sorry, no frills imagery *)
  184.     h := g.height DIV 2;
  185.     x := g.leftEdge + (wd DIV 2);
  186.     y := g.topEdge + (h DIV 2);
  187.  
  188.     gfx.Move (rp, x, SHORT (inst.midY));
  189.     gfx.Draw (rp, x + wd, y);
  190.     gfx.Draw (rp, x + wd, y + g.height - h);
  191.     gfx.Draw (rp, x, SHORT (inst.midY));
  192.  
  193.     x := g.leftEdge + (wd DIV 2) + g.width DIV 2;
  194.  
  195.     gfx.Move (rp, x + wd, SHORT (inst.midY));
  196.     gfx.Draw (rp, x, y);
  197.     gfx.Draw (rp, x, y + g.height - h);
  198.     gfx.Draw (rp, x + wd, SHORT (inst.midY));
  199.  
  200.     gfx.SetAPen (rp, SHORT (shine));              (* Draw shine edge *)
  201.     gfx.Move (rp, g.leftEdge, g.topEdge + g.height - 1);
  202.     gfx.Draw (rp, g.leftEdge, g.topEdge);
  203.     gfx.Draw (rp, g.leftEdge + g.width - 1, g.topEdge);
  204.  
  205.     IF msg.msg.methodID # i.gmRender THEN (* If we allocated a rastport, give *)
  206.                                       (* it back. *)
  207.       i.ReleaseGIRPort (rp)
  208.     END;
  209.   ELSE
  210.     retval := SYS.VAL (e.APTR, e.LFALSE);
  211.   END;
  212.   RETURN retval
  213. END RenderRKMBut;
  214.  
  215.  
  216. (*------------------------------------*)
  217. PROCEDURE NotifyPulse
  218.   ( cl    : i.IClassPtr;
  219.     o     : i.ObjectPtr;
  220.     flags : SET;
  221.     mid   : LONGINT;
  222.     gpi   : i.InputPtr );
  223.  
  224.   VAR
  225.     tt : ARRAY 3 OF u.TagItem;
  226.     g : i.GadgetPtr;
  227.     ignore : e.APTR;
  228.  
  229. BEGIN (* NotifyPulse *)
  230.   g := SYS.VAL (i.GadgetPtr, o);
  231.  
  232.   tt[0].tag := rkmButPulse;
  233.   tt[0].data := mid - gpi.mouse.x + g.leftEdge;
  234.  
  235.   tt[1].tag := i.gaID;
  236.   tt[1].data := g.gadgetID;
  237.  
  238.   tt[2].tag := u.done;
  239.  
  240.   ignore := cf.DoSuperMethod
  241.     (cl, o, i.omNotify, SYS.ADR (tt), gpi.gInfo, flags)
  242. END NotifyPulse;
  243.  
  244. (*------------------------------------*)
  245. PROCEDURE* dispatchRKMButGad
  246.   ( hook : u.HookPtr; obj : e.APTR; message : e.APTR )
  247.   : e.APTR;
  248.  
  249.   VAR
  250.     cl : i.IClassPtr; o : i.ObjectPtr; msg : i.MsgPtr;
  251.     inst : ButINSTPtr;
  252.     retval, ignore : SYS.LONGWORD;
  253.     object : i.ObjectPtr;
  254.     g : i.GadgetPtr;
  255.     gpi : i.InputPtr;
  256.     ie : IE.InputEventPtr;
  257.     rp : gfx.RastPortPtr;
  258.     x, y, wd, h : INTEGER;
  259.     pens : i.DRIPenArrayPtr;
  260.     opSet : i.OpSetPtr;
  261.  
  262. BEGIN (* dispatchRKMButGad *)
  263.   cl := SYS.VAL (i.IClassPtr, hook);
  264.   o := obj;
  265.   msg := message;
  266.   retval := e.LTRUE;
  267.   CASE msg.methodID OF
  268.     i.omNew : (* First, pass up to superclass *)
  269.       object := cf.DoSuperMethodA (cl, o, msg^);
  270.       IF object # NIL THEN
  271.         g := SYS.VAL (i.GadgetPtr, object);
  272.                 (* Initial local instance data *)
  273.         inst := cf.InstData (cl, object);
  274.         inst.midX := g.leftEdge + (g.width DIV 2);
  275.         inst.midY := g.topEdge + (g.height DIV 2);
  276.         retval := object
  277.       END;
  278.     |
  279.     i.gmHitTest :
  280.           (* Since this is a rectangular gadget this *)
  281.           (* method always returns i.gmrGadgetHit.   *)
  282.       retval := i.gmrGadgetHit;
  283.     |
  284.     i.gmGoActive :
  285.       inst := cf.InstData (cl, o);
  286.           (* Only become active if the gmGoActive *)
  287.           (* was triggered by direct user input.  *)
  288.       gpi :