home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 10 / Fresh_Fish_10_2352.bin / new / dev / obero / oberon-a / examples / libraries / intuition / lines.mod < prev    next >
Text File  |  1995-07-02  |  11KB  |  388 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: Lines.mod $
  4.   Description: A port of lines.c from the RKM:Libraries.
  5.  
  6.                Implements a superbitmap with scroll gadgets.
  7.  
  8.    Created by: fjc (Frank Copeland)
  9.     $Revision: 1.6 $
  10.       $Author: fjc $
  11.         $Date: 1995/01/25 23:52:19 $
  12.  
  13.   Copyright © 1994-1995, Frank Copeland.
  14.   This example program is part of Oberon-A.
  15.   See Oberon-A.doc for conditions of use and distribution.
  16.  
  17. *************************************************************************)
  18.  
  19. <* STANDARD- *>
  20.  
  21. MODULE Lines;
  22.  
  23. IMPORT
  24.   SYS := SYSTEM,
  25.   e   := Exec,
  26.   gfx := Graphics,
  27.   l   := Layers,
  28.   i   := Intuition,
  29.   rn  := RandomNumbers;
  30.  
  31. CONST VersionTag = "$VER: Lines 1.3 (24.1.95)\r\n";
  32.  
  33. (*------------------------------------*)
  34. CONST
  35.  
  36.   widthSuper  = 800;
  37.   heightSuper = 600;
  38.  
  39.   upDownGadget    = 0;
  40.   leftRightGadget = 1;
  41.   noGadget        = 2;
  42.  
  43.   maxPropVal = 0FFFFH;
  44.  
  45. VAR
  46.  
  47.   win          : i.WindowPtr;
  48.   botGadInfo   : i.PropInfo;
  49.   botGadImage  : i.Image;
  50.   botGad       : i.Gadget;
  51.   sideGadInfo  : i.PropInfo;
  52.   sideGadImage : i.Image;
  53.   sideGad      : i.Gadget;
  54.  
  55. (*------------------------------------*)
  56. PROCEDURE UWORD2LONGINT (x : e.UWORD) : LONGINT;
  57.  
  58. BEGIN (* UWORD2LONGINT *)
  59.   IF x < 0 THEN RETURN x + 10000H
  60.   ELSE RETURN x
  61.   END;
  62. END UWORD2LONGINT;
  63.  
  64. (*------------------------------------
  65. ** Replacement for amiga.lib function
  66. *)
  67. PROCEDURE RangeRand (maxValue : LONGINT) : LONGINT;
  68.  
  69. BEGIN (* RangeRand *)
  70.   RETURN ENTIER (rn.Uniform () * (maxValue + 1))
  71. END RangeRand;
  72.  
  73. (*------------------------------------
  74. ** Set-up the prop gadgets--initialize them to values that fit
  75. ** into the window border.  The height of the prop gadget on the side
  76. ** of the window takes the height fo the title bar into account in its
  77. ** set-up. Note the initialization assumes a fixed size "sizing" gadget.
  78. **
  79. ** Note also, that the size of the sizing gadget is dependent on the
  80. ** screen resolution.  The numbers given here are only valid if the
  81. ** screen is NOT lo-res.  These values must be re-worked slightly
  82. ** for lo-res screens.
  83. *)
  84. PROCEDURE InitBorderProps (myScreen : i.ScreenPtr);
  85.  
  86. BEGIN (* InitBorderProps *)
  87.   (* Initializes the two prop gadgets.
  88.   **
  89.   ** Note where the propNewLook flag goes.  Adding this flag requires
  90.   ** no extra storage, but tells the system that our program is
  91.   ** expecting the new-look prop gadgets under 2.0.
  92.   *)
  93.   botGadInfo.flags     := { i.autoKnob, i.freeHoriz, i.propNewlook };
  94.   botGadInfo.horizPot  := 0;
  95.   botGadInfo.vertPot   := 0;
  96.   botGadInfo.horizBody := -1;
  97.   botGadInfo.vertBody  := -1;
  98.  
  99.   botGad.leftEdge      := 3;
  100.   botGad.topEdge       := -7;
  101.   botGad.width         := -23;
  102.   botGad.height        := 6;
  103.   botGad.flags         := { i.gRelBottom, i.gRelWidth };
  104.   botGad.activation    := { i.relVerify, i.gadgImmediate, i.bottomBorder };
  105.   botGad.gadgetType    := i.propGadget + i.gzzGadget;
  106.   botGad.gadgetRender  := SYS.ADR (botGadImage);
  107.   botGad.specialInfo   := SYS.ADR (botGadInfo);
  108.   botGad.gadgetID      := leftRightGadget;
  109.  
  110.   sideGadInfo.flags     := { i.autoKnob, i.freeVert, i.propNewlook };
  111.   sideGadInfo.horizPot  := 0;
  112.   sideGadInfo.vertPot   := 0;
  113.   sideGadInfo.horizBody := -1;
  114.   sideGadInfo.vertBody  := -1;
  115.  
  116.   sideGad.leftEdge      := -14;
  117.   sideGad.topEdge       := myScreen.wBorTop + myScreen.font.ySize + 2;
  118.   sideGad.width         := 12;
  119.   sideGad.height        := -sideGad.topEdge - 11;
  120.   sideGad.flags         := { i.gRelRight, i.gRelHeight };
  121.   sideGad.activation    := { i.relVerify, i.gadgImmediate, i.rightBorder };
  122.   sideGad.gadgetType    := i.propGadget + i.gzzGadget;
  123.   sideGad.gadgetRender  := SYS.ADR (sideGadImage);
  124.   sideGad.specialInfo   := SYS.ADR (sideGadInfo);
  125.   sideGad.gadgetID      := upDownGadget;
  126.   sideGad.nextGadget    := SYS.ADR (botGad);
  127. END InitBorderProps;
  128.  
  129. (*------------------------------------*)
  130. PROCEDURE DoDrawStuff ();
  131.  
  132.   VAR
  133.     x1, y1, x2, y2 : INTEGER;
  134.     pen, ncolors, deltx, delty : INTEGER;
  135.  
  136. BEGIN (* DoDrawStuff *)
  137.   ncolors := SHORT (ASH (1, win.wScreen.bitMap.depth));
  138.   deltx := SHORT (RangeRand (6)) + 2;
  139.   delty := SHORT (RangeRand (6)) + 2;
  140.  
  141.   pen := SHORT (RangeRand (ncolors - 1)) + 1;
  142.   gfx.SetAPen (win.rPort, SHORT (pen));
  143.   x1 := 0; y1 := 0; x2 := widthSuper - 1; y2 := heightSuper - 1;
  144.   WHILE x1 < widthSuper DO
  145.     gfx.Move (win.rPort, x1, y1);
  146.     gfx.Draw (win.rPort, x2, y2);
  147.     INC (x1, deltx); DEC (x2, deltx)
  148.   END;
  149.  
  150.   pen := SHORT (RangeRand (ncolors - 1)) + 1;
  151.   gfx.SetAPen (win.rPort, SHORT (pen));
  152.   x1 := 0; y1 := 0; x2 := widthSuper - 1; y2 := heightSuper - 1;
  153.   WHILE y1 < heightSuper DO
  154.     gfx.Move (win.rPort, x1, y1);
  155.     gfx.Draw (win.rPort, x2, y2);
  156.     INC (y1, delty); DEC (y2, delty)
  157.   END;
  158. END DoDrawStuff;
  159.  
  160. (*------------------------------------
  161. ** This function provides a simple interface to ScrollLayer()
  162. *)
  163. PROCEDURE SlideBitMap (Dx, Dy : INTEGER);
  164.  
  165. BEGIN (* SlideBitMap *)
  166.   l.ScrollLayer (win.rPort.layer, Dx, Dy)
  167. END SlideBitMap;
  168.  
  169. (*------------------------------------
  170. ** Update the prop gadgets and bitmap positioning when the size changes.
  171. *)
  172. PROCEDURE DoNewSize ();
  173.  
  174.   VAR
  175.     tmp : e.ULONG;
  176.     scrollX, scrollY : INTEGER;
  177.  
  178. BEGIN (* DoNewSize *)
  179.   scrollX := win.rPort.layer.scrollX;
  180.   scrollY := win.rPort.layer.scrollY;
  181.  
  182.   tmp := scrollX + win.gzzWidth;
  183.   IF tmp >= widthSuper THEN
  184.     SlideBitMap (widthSuper - SHORT (tmp), 0)
  185.   END;
  186.  
  187.   i.NewModifyProp
  188.     ( botGad, win, NIL, {i.autoKnob, i.freeHoriz},
  189.       ( (scrollX * maxPropVal) DIV
  190.         (widthSuper - win.gzzWidth) ),
  191.       0,
  192.       ((win.gzzWidth * maxPropVal) DIV widthSuper),
  193.       maxPropVal, 1 );
  194.  
  195.   tmp := scrollY + win.gzzHeight;
  196.   IF tmp >= heightSuper THEN
  197.     SlideBitMap (0, heightSuper - SHORT (tmp))
  198.   END;
  199.  
  200.   i.NewModifyProp
  201.     ( sideGad, win, NIL, {i.autoKnob, i.freeVert},
  202.       0,
  203.       ( (scrollY * maxPropVal) DIV
  204.         (heightSuper - win.gzzHeight) ),
  205.       maxPropVal,
  206.       ((win.gzzHeight * maxPropVal) DIV heightSuper),
  207.       1 );
  208. END DoNewSize;
  209.  
  210. (*------------------------------------
  211. ** Process the currently selected gadget.
  212. ** This is called from i.idcmpIntuiTicks and when the gadget is released
  213. ** i.idcmpGadgetUp.
  214. *)
  215. PROCEDURE CheckGadget (gadgetID : e.UWORD);
  216.  
  217.   VAR
  218.     tmp : e.ULONG;
  219.     dX : INTEGER;
  220.     dY : INTEGER;
  221.  
  222. BEGIN (* CheckGadget *)
  223.   dX := 0; dY := 0;
  224.  
  225.   CASE gadgetID OF
  226.     upDownGadget :
  227.       tmp := heightSuper - win.gzzHeight;
  228.       tmp := tmp * UWORD2LONGINT (sideGadInfo.vertPot);
  229.       tmp := tmp DIV maxPropVal;
  230.       dY := SHORT (tmp) - win.rPort.layer.scrollY
  231.     |
  232.     leftRightGadget :
  233.       tmp := widthSuper - win.gzzWidth;
  234.       tmp := tmp * UWORD2LONGINT (botGadInfo.horizPot);
  235.       tmp := tmp DIV maxPropVal;
  236.       dX := SHORT (tmp) - win.rPort.layer.scrollX
  237.     |
  238.   ELSE (* gadgetID = noGadget *)
  239.   END; (* CASE gadgetID *)
  240.  
  241.   IF (dX # 0) OR (dY # 0) THEN
  242.     SlideBitMap (dX, dY)
  243.   END;
  244. END CheckGadget;
  245.  
  246. (*------------------------------------
  247. ** Main message loop for the window.
  248. *)
  249. PROCEDURE DoMsgLoop ();
  250.  
  251.   VAR
  252.     msg : i.IntuiMessagePtr;
  253.     flag : BOOLEAN;
  254.     currentGadget : e.UWORD;
  255.     gadget : i.GadgetPtr;
  256.  
  257. BEGIN (* DoMsgLoop *)
  258.   flag := TRUE; currentGadget := noGadget;
  259.   WHILE flag DO
  260.     (*
  261.     ** Whenever you want to wait on just one message port
  262.     ** you can use WaitPort(). WaitPort() doesn't require
  263.     ** the setting of a signal bit. The only argument it
  264.     ** requires is the pointer to the window's userPort.
  265.     *)
  266.     e.WaitPort (win.userPort);
  267.     LOOP
  268.       msg := SYS.VAL (i.IntuiMessagePtr, e.GetMsg (win.userPort));
  269.       IF msg = NIL THEN EXIT END;
  270.       gadget := msg.iAddress;
  271.       IF msg.class = {i.closeWindow} THEN
  272.         flag := FALSE
  273.       ELSIF msg.class = {i.newSize} THEN
  274.         DoNewSize();
  275.         DoDrawStuff()
  276.       ELSIF msg.class = {i.gadgetDown} THEN
  277.         currentGadget := gadget.gadgetID
  278.       ELSIF msg.class = {i.gadgetUp} THEN
  279.         CheckGadget (currentGadget);
  280.         currentGadget := noGadget
  281.       ELSIF msg.class = {i.intuiTicks} THEN
  282.         CheckGadget (currentGadget)
  283.       END;
  284.       e.ReplyMsg (msg)
  285.     END;
  286.   END;
  287. END DoMsgLoop;
  288.  
  289. (*------------------------------------*)
  290. PROCEDURE SuperWindow (myScreen : i.ScreenPtr);
  291.  
  292.   VAR
  293.     b