home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / useful / dev / obero / oberon-a / examples / libraries / intuition / lines.mod < prev    next >
Encoding:
Text File  |  1994-08-08  |  12.0 KB  |  418 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.4 $
  10.       $Author: fjc $
  11.         $Date: 1994/08/08 16:55:25 $
  12.  
  13.   Copyright © 1994, Frank Copeland.
  14.   This example program is part of Oberon-A.
  15.   See Oberon-A.doc for conditions of use and distribution.
  16.  
  17.   Log entries are at the end of the file.
  18.  
  19. *************************************************************************)
  20.  
  21. MODULE Lines;
  22.  
  23. (*
  24. ** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
  25. ** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  26. ** $V= OvflChk       $Z= ZeroVars
  27. *)
  28.  
  29. IMPORT
  30.   SYS := SYSTEM,
  31.   e   := Exec,
  32.   gfx := Graphics,
  33.   l   := Layers,
  34.   i   := Intuition,
  35.   rn  := RandomNumbers;
  36.  
  37. CONST
  38.   VersionTag = "$VER: Lines 1.0 (16.6.94)";
  39.  
  40. (*------------------------------------*)
  41. CONST
  42.  
  43.   widthSuper  = 800;
  44.   heightSuper = 600;
  45.  
  46.   upDownGadget    = 0;
  47.   leftRightGadget = 1;
  48.   noGadget        = 2;
  49.  
  50.   maxPropVal = 0FFFFH;
  51.  
  52. VAR
  53.  
  54.   win          : i.WindowPtr;
  55.   botGadInfo   : i.PropInfo;
  56.   botGadImage  : i.Image;
  57.   botGad       : i.Gadget;
  58.   sideGadInfo  : i.PropInfo;
  59.   sideGadImage : i.Image;
  60.   sideGad      : i.Gadget;
  61.  
  62. (*------------------------------------*)
  63. PROCEDURE UWORD2LONGINT (x : e.UWORD) : LONGINT;
  64.  
  65. BEGIN (* UWORD2LONGINT *)
  66.   IF x < 0 THEN RETURN x + 10000H
  67.   ELSE RETURN x
  68.   END;
  69. END UWORD2LONGINT;
  70.  
  71. (*------------------------------------
  72. ** Replacement for amiga.lib function
  73. *)
  74. PROCEDURE RangeRand (maxValue : LONGINT) : LONGINT;
  75.  
  76. BEGIN (* RangeRand *)
  77.   RETURN ENTIER (rn.Uniform () * (maxValue + 1))
  78. END RangeRand;
  79.  
  80. (*------------------------------------
  81. ** Set-up the prop gadgets--initialize them to values that fit
  82. ** into the window border.  The height of the prop gadget on the side
  83. ** of the window takes the height fo the title bar into account in its
  84. ** set-up. Note the initialization assumes a fixed size "sizing" gadget.
  85. **
  86. ** Note also, that the size of the sizing gadget is dependent on the
  87. ** screen resolution.  The numbers given here are only valid if the
  88. ** screen is NOT lo-res.  These values must be re-worked slightly
  89. ** for lo-res screens.
  90. *)
  91. PROCEDURE InitBorderProps (myScreen : i.ScreenPtr);
  92.  
  93. BEGIN (* InitBorderProps *)
  94.   (* Initializes the two prop gadgets.
  95.   **
  96.   ** Note where the propNewLook flag goes.  Adding this flag requires
  97.   ** no extra storage, but tells the system that our program is
  98.   ** expecting the new-look prop gadgets under 2.0.
  99.   *)
  100.   botGadInfo.flags     := { i.autoKnob, i.freeHoriz, i.propNewlook };
  101.   botGadInfo.horizPot  := 0;
  102.   botGadInfo.vertPot   := 0;
  103.   botGadInfo.horizBody := -1;
  104.   botGadInfo.vertBody  := -1;
  105.  
  106.   botGad.leftEdge      := 3;
  107.   botGad.topEdge       := -7;
  108.   botGad.width         := -23;
  109.   botGad.height        := 6;
  110.   botGad.flags         := {i.gflgRelBottom, i.gflgRelWidth};
  111.   botGad.activation    := { i.gactRelVerify, i.gactImmediate,
  112.                             i.gactBottomBorder };
  113.   botGad.gadgetType    := i.gtypPropGadget + i.gtypGzzGadget;
  114.   botGad.gadgetRender  := SYS.ADR (botGadImage);
  115.   botGad.specialInfo   := SYS.ADR (botGadInfo);
  116.   botGad.gadgetID      := leftRightGadget;
  117.  
  118.   sideGadInfo.flags     := { i.autoKnob, i.freeVert, i.propNewlook };
  119.   sideGadInfo.horizPot  := 0;
  120.   sideGadInfo.vertPot   := 0;
  121.   sideGadInfo.horizBody := -1;
  122.   sideGadInfo.vertBody  := -1;
  123.  
  124.   sideGad.leftEdge      := -14;
  125.   sideGad.topEdge       := myScreen.wBorTop + myScreen.font.ySize + 2;
  126.   sideGad.width         := 12;
  127.   sideGad.height        := -sideGad.topEdge - 11;
  128.   sideGad.flags         := {i.gflgRelRight, i.gflgRelHeight};
  129.   sideGad.activation    := { i.gactRelVerify, i.gactImmediate,
  130.                              i.gactRightBorder };
  131.   sideGad.gadgetType    := i.gtypPropGadget + i.gtypGzzGadget;
  132.   sideGad.gadgetRender  := SYS.ADR (sideGadImage);
  133.   sideGad.specialInfo   := SYS.ADR (sideGadInfo);
  134.   sideGad.gadgetID      := upDownGadget;
  135.   sideGad.nextGadget    := SYS.ADR (botGad);
  136. END InitBorderProps;
  137.  
  138. (*------------------------------------*)
  139. PROCEDURE DoDrawStuff ();
  140.  
  141.   VAR
  142.     x1, y1, x2, y2 : INTEGER;
  143.     pen, ncolors, deltx, delty : INTEGER;
  144.  
  145. BEGIN (* DoDrawStuff *)
  146.   ncolors := SHORT (ASH (1, ORD (win.wScreen.bitMap.depth)));
  147.   deltx := SHORT (RangeRand (6)) + 2;
  148.   delty := SHORT (RangeRand (6)) + 2;
  149.  
  150.   pen := SHORT (RangeRand (ncolors - 1)) + 1;
  151.   gfx.base.SetAPen (win.rPort, SHORT (pen));
  152.   x1 := 0; y1 := 0; x2 := widthSuper - 1; y2 := heightSuper - 1;
  153.   WHILE x1 < widthSuper DO
  154.     gfx.base.Move (win.rPort, x1, y1);
  155.     gfx.base.Draw (win.rPort, x2, y2);
  156.     INC (x1, deltx); DEC (x2, deltx)
  157.   END;
  158.  
  159.   pen := SHORT (RangeRand (ncolors - 1)) + 1;
  160.   gfx.base.SetAPen (win.rPort, SHORT (pen));
  161.   x1 := 0; y1 := 0; x2 := widthSuper - 1; y2 := heightSuper - 1;
  162.   WHILE y1 < heightSuper DO
  163.     gfx.base.Move (win.rPort, x1, y1);
  164.     gfx.base.Draw (win.rPort, x2, y2);
  165.     INC (y1, delty); DEC (y2, delty)
  166.   END;
  167. END DoDrawStuff;
  168.  
  169. (*------------------------------------
  170. ** This function provides a simple interface to ScrollLayer()
  171. *)
  172. PROCEDURE SlideBitMap (Dx, Dy : INTEGER);
  173.  
  174. BEGIN (* SlideBitMap *)
  175.   l.base.ScrollLayer (win.rPort.layer, Dx, Dy)
  176. END SlideBitMap;
  177.  
  178. (*------------------------------------
  179. ** Update the prop gadgets and bitmap positioning when the size changes.
  180. *)
  181. PROCEDURE DoNewSize ();
  182.  
  183.   VAR
  184.     tmp : e.ULONG;
  185.     scrollX, scrollY : INTEGER;
  186.  
  187. BEGIN (* DoNewSize *)
  188.   scrollX := win.rPort.layer.scrollX;
  189.   scrollY := win.rPort.layer.scrollY;
  190.  
  191.   tmp := scrollX + win.gzzWidth;
  192.   IF tmp >= widthSuper THEN
  193.     SlideBitMap (widthSuper - SHORT (tmp), 0)
  194.   END;
  195.  
  196.   i.base.NewModifyProp
  197.     ( botGad, win, NIL, {i.autoKnob, i.freeHoriz},
  198.       ( (scrollX * maxPropVal) DIV
  199.         (widthSuper - win.gzzWidth) ),
  200.       0,
  201.       ((win.gzzWidth * maxPropVal) DIV widthSuper),
  202.       maxPropVal, 1 );
  203.  
  204.   tmp := scrollY + win.gzzHeight;
  205.   IF tmp >= heightSuper THEN
  206.     SlideBitMap (0, heightSuper - SHORT (tmp))
  207.   END;
  208.  
  209.   i.base.NewModifyProp
  210.     ( sideGad, win, NIL, {i.autoKnob, i.freeVert},
  211.       0,
  212.       ( (scrollY * maxPropVal) DIV
  213.         (heightSuper - win.gzzHeight) ),
  214.       maxPropVal,
  215.       ((win.gzzHeight * maxPropVal) DIV heightSuper),
  216.       1 );
  217. END DoNewSize;
  218.  
  219. (*------------------------------------
  220. ** Process the currently selected gadget.
  221. ** This is called from i.idcmpIntuiTicks and when the gadget is released
  222. ** i.idcmpGadgetUp.
  223. *)
  224. PROCEDURE CheckGadget (gadgetID : e.UWORD);
  225.  
  226.   VAR
  227.     tmp : e.ULONG;
  228.     dX : INTEGER;
  229.     dY : INTEGER;
  230.  
  231. BEGIN (* CheckGadget *)
  232.   dX := 0; dY := 0;
  233.  
  234.   CASE gadgetID OF
  235.     upDownGadget :
  236.       tmp := heightSuper - win.gzzHeight;
  237.       tmp := tmp * UWORD2LONGINT (sideGadInfo.vertPot);
  238.       tmp := tmp DIV maxPropVal;
  239.       dY := SHORT (tmp) - win.rPort.layer.scrollY
  240.     |
  241.     leftRightGadget :
  242.       tmp := widthSuper - win.gzzWidth;
  243.       tmp := tmp * UWORD2LONGINT (botGadInfo.horizPot);
  244.       tmp := tmp DIV maxPropVal;
  245.       dX := SHORT (tmp) - win.rPort.layer.scrollX
  246.     |
  247.   ELSE (* gadgetID = noGadget *)
  248.   END; (* CASE gadgetID *)
  249.  
  250.   IF (dX # 0) OR (dY # 0) THEN
  251.     SlideBitMap (dX, dY)
  252.   END;
  253. END CheckGadget;
  254.  
  255. (*------------------------------------
  256. ** Main message loop for the window.
  257. *)
  258. PROCEDURE DoMsgLoop ();
  259.  
  260.   VAR
  261.     msg : i.IntuiMessagePtr;
  262.     flag : BOOLEAN;
  263.     currentGadget : e.UWORD;
  264.     gadget : i.GadgetPtr;
  265.  
  266. BEGIN (* DoMsgLoop *)
  267.   flag := TRUE; currentGadget := noGadget;
  268.   WHILE flag DO
  269.     (*
  270.     ** Whenever you want to wait on just one message port
  271.     ** you can use WaitPort(). WaitPort() doesn't require
  272.     ** the setting of a signal bit. The only argument it
  273.     ** requires is the pointer to the window's userPort.
  274.     *)
  275.     e.base.WaitPort (win.userPort);
  276.     LOOP
  277.       msg := SYS.VAL (i.IntuiMessagePtr, e.base.GetMsg (win.userPort));
  278.       IF msg = NIL THEN EXIT END;
  279.       gadget := msg.iAddress;
  280.       IF msg.class = {i.idcmpCloseWindow} THEN
  281.         flag := FALSE
  282.       ELSIF msg.class = {i.idcmpNewSize} THEN
  283.         DoNewSize();
  284.         DoDrawStuff()
  285.       ELSIF msg.class = {i.idcmpGadgetDown} THEN
  286.         currentGadget := gadget.gadgetID
  287.       ELSIF msg.class = {i.idcmpGadgetUp} THEN
  288.         CheckGadget (currentGadget);
  289.         currentGadget := noGadget
  290.       ELSIF msg.class = {i.idcmpIntuiTicks} THEN
  291.         CheckGadget (currentGadget)
  292.       END;
  293.       e.base.ReplyMsg (msg)
  294.     END;
  295.   END;
  296. END DoMsgLoop;
  297.  
  298. (*------------------------------------*)
  299. PROCEDURE SuperWindow (myScreen : i.ScreenPtr);
  300.  
  301.   VAR
  302.     bigBitMap : gfx.BitMapPtr;
  303.     planeNum : INTEGER;
  304.     allocatedBitMaps : BOOLEAN;
  305.  
  306. BEGIN (* SuperWindow *)
  307.   (* set-up the border prop gadgets for the OpenWindow() call. *)
  308.   InitBorderProps (myScreen);
  309.  
  310.   (* The code relies on the allocation of the BitMap structure with
  311.   ** the memClear flag.  This allows the assumption that all of the
  312.   ** bitmap pointers are NIL, except those successfully allocated
  313.   ** by the program.
  314.   *)
  315.   bigBitMap :=
  316.     e.base.AllocMem (SIZE (gfx.BitMap), {e.memPublic, e.memClear});
  317.   IF bigBitMap # NIL THEN
  318.     gfx.base.InitBitMap
  319.       ( bigBitMap^, myScreen.bitMap.depth, widthSuper, heightSuper );
  320.  
  321.     allocatedBitMaps := TRUE;
  322.     planeNum := 0;
  323.     WHILE (planeNum < ORD (myScreen.bitMap.depth)) & allocatedBitMaps DO
  324.       bigBitMap.planes [planeNum] :=
  325.         gfx.base.AllocRaster (widthSuper, heightSuper);
  326.       allocatedBitMaps := (bigBitMap.planes [planeNum] # NIL);
  327.       INC (planeNum)
  328.     END;
  329.  
  330.     (* Only open the window if the bitplanes were successfully
  331.     ** allocated.  Fail silently if they were not.
  332.     *)
  333.     IF allocatedBitMaps THEN
  334.       (* OpenWindowTags() and OpenWindowTagList() are only available
  335.       ** when the lebrary version is at least V36.  Under earlier
  336.       ** versions of Intuition, use OpenWindow() with a NewWindow
  337.       ** structure.
  338.       *)
  339.       win := i.base.OpenWindowTagsA
  340.         ( NIL,
  341.           i.waWidth,     150,
  342.           i.waHeight,    LONG ( 4 *
  343.                            ( LONG (myScreen.wBorTop) +
  344.                              myScreen.font.ySize + 1)),
  345.           i.waMaxWidth,  widthSuper,
  346.           i.waMaxHeight, heightSuper,
  347.           i.waIDCMP,     { i.idcmpGadgetUp, i.idcmpGadgetDown,
  348.                            i.idcmpNewSize, i.idcmpIntuiTicks,
  349.                            i.idcmpCloseWindow },
  350.           i.waFlags,     { i.wflgSizeGadget, i.wflgSizeBRight,
  351.                            i.wflgSizeBBottom, i.wflgDragBar,
  352.                            i.wflgDepthGadget, i.wflgCloseGadget,
  353.                            i.wflgSuperBitmap, i.wflgGimmeZeroZero,
  354.                            i.wflgNoCareRefresh },
  355.           i.waGadgets,     SYS.ADR (sideGad),
  356.           i.waTitle,       SYS.VAL (LONGINT, SYS.ADR (VersionTag)) + 6,
  357.           i.waPubScreen,   myScreen,
  358.           i.waSuperBitMap, bigBitMap,
  359.           0 );
  360.       IF win # NIL THEN
  361.         (* set-up the window display *)
  362.         gfx.base.SetRast (win.rPort, 0);
  363.         gfx.base.SetDrMd (win.rPort, gfx.jam1);
  364.         DoNewSize (); (* adjust props to represent portion visible *)
  365.         DoDrawStuff ();
  366.  
  367.         (* process the window, return on idcmpCloseWindow *)
  368.         DoMsgLoop ();
  369.         i.base.CloseWindow (win)
  370.       END;
  371.     END;
  372.     FOR planeNum := 0 TO ORD (myScreen.bitMap.depth) - 1 DO
  373.       gfx.base.FreeRaster
  374.         ( bigBitMap.planes [planeNum], widthSuper, heightSuper )
  375.     END;
  376.     e.base.FreeMem (bigBitMap, SIZE (gfx.BitMap))
  377.   END;
  378. END SuperWindow;
  379.  
  380. (*------------------------------------*)
  381. PROCEDURE Main ();
  382.  
  383.   VAR
  384.     myScreen : i.ScreenPtr;
  385.  
  386. BEGIN (* Main *)
  387.   IF i.base.version >= 37 THEN
  388.     myScreen := i.base.LockPubScreen ("");
  389.     IF myScreen # NIL THEN
  390.       SuperWindow (myScreen);
  391.       i.base.UnlockPubScreen ("", myScreen);
  392.     END
  393.   END
  394. END Main;
  395.  
  396. BEGIN (* Lines *)
  397.   rn.TimeSeed ();
  398.   Main ();
  399. END Lines.
  400.  
  401. (*************************************************************************
  402.  
  403.   $Log: Lines.mod $
  404.   Revision 1.4  1994/08/08  16:55:25  fjc
  405.   Release 1.4
  406.  
  407.   Revision 1.3  1994/07/03  15:11:48  fjc
  408.   - Incorporated changes in 3.1 Interfaces
  409.  
  410.   Revision 1.2  1994/06/20  20:22:34  fjc
  411.   - Minor modification.
  412.  
  413. # Revision 1.1  1994/06/17  18:19:52  fjc
  414. # Initial revision
  415. #
  416. *************************************************************************)
  417.  
  418.