Workbench Add-On/Workbench Add-On - Volume 1.iso/Dev/Oberon/examples.lha/Examples/Libraries/Intuition/Lines.mod

Text File | 1995-07-02 | 11.0 KB | 388 lines

(*************************************************************************

     $RCSfile: Lines.mod $
  Description: A port of lines.c from the RKM:Libraries.

               Implements a superbitmap with scroll gadgets.

   Created by: fjc (Frank Copeland)
    $Revision: 1.6 $
      $Author: fjc $
        $Date: 1995/01/25 23:52:19 $

  Copyright © 1994-1995, Frank Copeland.
  This example program is part of Oberon-A.
  See Oberon-A.doc for conditions of use and distribution.

*************************************************************************)

<* STANDARD- *>

MODULE Lines;

IMPORT
  SYS := SYSTEM,
  e   := Exec,
  gfx := Graphics,
  l   := Layers,
  i   := Intuition,
  rn  := RandomNumbers;

CONST VersionTag = "$VER: Lines 1.3 (24.1.95)\r\n";

(*------------------------------------*)
CONST

  widthSuper  = 800;
  heightSuper = 600;

  upDownGadget    = 0;
  leftRightGadget = 1;
  noGadget        = 2;

  maxPropVal = 0FFFFH;

VAR

  win          : i.WindowPtr;
  botGadInfo   : i.PropInfo;
  botGadImage  : i.Image;
  botGad       : i.Gadget;
  sideGadInfo  : i.PropInfo;
  sideGadImage : i.Image;
  sideGad      : i.Gadget;

(*------------------------------------*)
PROCEDURE UWORD2LONGINT (x : e.UWORD) : LONGINT;

BEGIN (* UWORD2LONGINT *)
  IF x < 0 THEN RETURN x + 10000H
  ELSE RETURN x
  END;
END UWORD2LONGINT;

(*------------------------------------
** Replacement for amiga.lib function
*)
PROCEDURE RangeRand (maxValue : LONGINT) : LONGINT;

BEGIN (* RangeRand *)
  RETURN ENTIER (rn.Uniform () * (maxValue + 1))
END RangeRand;

(*------------------------------------
** Set-up the prop gadgets--initialize them to values that fit
** into the window border.  The height of the prop gadget on the side
** of the window takes the height fo the title bar into account in its
** set-up. Note the initialization assumes a fixed size "sizing" gadget.
**
** Note also, that the size of the sizing gadget is dependent on the
** screen resolution.  The numbers given here are only valid if the
** screen is NOT lo-res.  These values must be re-worked slightly
** for lo-res screens.
*)
PROCEDURE InitBorderProps (myScreen : i.ScreenPtr);

BEGIN (* InitBorderProps *)
  (* Initializes the two prop gadgets.
  **
  ** Note where the propNewLook flag goes.  Adding this flag requires
  ** no extra storage, but tells the system that our program is
  ** expecting the new-look prop gadgets under 2.0.
  *)
  botGadInfo.flags     := { i.autoKnob, i.freeHoriz, i.propNewlook };
  botGadInfo.horizPot  := 0;
  botGadInfo.vertPot   := 0;
  botGadInfo.horizBody := -1;
  botGadInfo.vertBody  := -1;

  botGad.leftEdge      := 3;
  botGad.topEdge       := -7;
  botGad.width         := -23;
  botGad.height        := 6;
  botGad.flags         := { i.gRelBottom, i.gRelWidth };
  botGad.activation    := { i.relVerify, i.gadgImmediate, i.bottomBorder };
  botGad.gadgetType    := i.propGadget + i.gzzGadget;
  botGad.gadgetRender  := SYS.ADR (botGadImage);
  botGad.specialInfo   := SYS.ADR (botGadInfo);
  botGad.gadgetID      := leftRightGadget;

  sideGadInfo.flags     := { i.autoKnob, i.freeVert, i.propNewlook };
  sideGadInfo.horizPot  := 0;
  sideGadInfo.vertPot   := 0;
  sideGadInfo.horizBody := -1;
  sideGadInfo.vertBody  := -1;

  sideGad.leftEdge      := -14;
  sideGad.topEdge       := myScreen.wBorTop + myScreen.font.ySize + 2;
  sideGad.width         := 12;
  sideGad.height        := -sideGad.topEdge - 11;
  sideGad.flags         := { i.gRelRight, i.gRelHeight };
  sideGad.activation    := { i.relVerify, i.gadgImmediate, i.rightBorder };
  sideGad.gadgetType    := i.propGadget + i.gzzGadget;
  sideGad.gadgetRender  := SYS.ADR (sideGadImage);
  sideGad.specialInfo   := SYS.ADR (sideGadInfo);
  sideGad.gadgetID      := upDownGadget;
  sideGad.nextGadget    := SYS.ADR (botGad);
END InitBorderProps;

(*------------------------------------*)
PROCEDURE DoDrawStuff ();

  VAR
    x1, y1, x2, y2 : INTEGER;
    pen, ncolors, deltx, delty : INTEGER;

BEGIN (* DoDrawStuff *)
  ncolors := SHORT (ASH (1, win.wScreen.bitMap.depth));
  deltx := SHORT (RangeRand (6)) + 2;
  delty := SHORT (RangeRand (6)) + 2;

  pen := SHORT (RangeRand (ncolors - 1)) + 1;
  gfx.SetAPen (win.rPort, SHORT (pen));
  x1 := 0; y1 := 0; x2 := widthSuper - 1; y2 := heightSuper - 1;
  WHILE x1 < widthSuper DO
    gfx.Move (win.rPort, x1, y1);
    gfx.Draw (win.rPort, x2, y2);
    INC (x1, deltx); DEC (x2, deltx)
  END;

  pen := SHORT (RangeRand (ncolors - 1)) + 1;
  gfx.SetAPen (win.rPort, SHORT (pen));
  x1 := 0; y1 := 0; x2 := widthSuper - 1; y2 := heightSuper - 1;
  WHILE y1 < heightSuper DO
    gfx.Move (win.rPort, x1, y1);
    gfx.Draw (win.rPort, x2, y2);
    INC (y1, delty); DEC (y2, delty)
  END;
END DoDrawStuff;

(*------------------------------------
** This function provides a simple interface to ScrollLayer()
*)
PROCEDURE SlideBitMap (Dx, Dy : INTEGER);

BEGIN (* SlideBitMap *)
  l.ScrollLayer (win.rPort.layer, Dx, Dy)
END SlideBitMap;

(*------------------------------------
** Update the prop gadgets and bitmap positioning when the size changes.
*)
PROCEDURE DoNewSize ();

  VAR
    tmp : e.ULONG;
    scrollX, scrollY : INTEGER;

BEGIN (* DoNewSize *)
  scrollX := win.rPort.layer.scrollX;
  scrollY := win.rPort.layer.scrollY;

  tmp := scrollX + win.gzzWidth;
  IF tmp >= widthSuper THEN
    SlideBitMap (widthSuper - SHORT (tmp), 0)
  END;

  i.NewModifyProp
    ( botGad, win, NIL, {i.autoKnob, i.freeHoriz},
      ( (scrollX * maxPropVal) DIV
        (widthSuper - win.gzzWidth) ),
      0,
      ((win.gzzWidth * maxPropVal) DIV widthSuper),
      maxPropVal, 1 );

  tmp := scrollY + win.gzzHeight;
  IF tmp >= heightSuper THEN
    SlideBitMap (0, heightSuper - SHORT (tmp))
  END;

  i.NewModifyProp
    ( sideGad, win, NIL, {i.autoKnob, i.freeVert},
      0,
      ( (scrollY * maxPropVal) DIV
        (heightSuper - win.gzzHeight) ),
      maxPropVal,
      ((win.gzzHeight * maxPropVal) DIV heightSuper),
      1 );
END DoNewSize;

(*------------------------------------
** Process the currently selected gadget.
** This is called from i.idcmpIntuiTicks and when the gadget is released
** i.idcmpGadgetUp.
*)
PROCEDURE CheckGadget (gadgetID : e.UWORD);

  VAR
    tmp : e.ULONG;
    dX : INTEGER;
    dY : INTEGER;

BEGIN (* CheckGadget *)
  dX := 0; dY := 0;

  CASE gadgetID OF
    upDownGadget :
      tmp := heightSuper - win.gzzHeight;
      tmp := tmp * UWORD2LONGINT (sideGadInfo.vertPot);
      tmp := tmp DIV maxPropVal;
      dY := SHORT (tmp) - win.rPort.layer.scrollY
    |
    leftRightGadget :
      tmp := widthSuper - win.gzzWidth;
      tmp := tmp * UWORD2LONGINT (botGadInfo.horizPot);
      tmp := tmp DIV maxPropVal;
      dX := SHORT (tmp) - win.rPort.layer.scrollX
    |
  ELSE (* gadgetID = noGadget *)
  END; (* CASE gadgetID *)

  IF (dX # 0) OR (dY # 0) THEN
    SlideBitMap (dX, dY)
  END;
END CheckGadget;

(*------------------------------------
** Main message loop for the window.
*)
PROCEDURE DoMsgLoop ();

  VAR
    msg : i.IntuiMessagePtr;
    flag : BOOLEAN;
    currentGadget : e.UWORD;
    gadget : i.GadgetPtr;

BEGIN (* DoMsgLoop *)
  flag := TRUE; currentGadget := noGadget;
  WHILE flag DO
    (*
    ** Whenever you want to wait on just one message port
    ** you can use WaitPort(). WaitPort() doesn't require
    ** the setting of a signal bit. The only argument it
    ** requires is the pointer to the window's userPort.
    *)
    e.WaitPort (win.userPort);
    LOOP
      msg := SYS.VAL (i.IntuiMessagePtr, e.GetMsg (win.userPort));
      IF msg = NIL THEN EXIT END;
      gadget := msg.iAddress;
      IF msg.class = {i.closeWindow} THEN
        flag := FALSE
      ELSIF msg.class = {i.newSize} THEN
        DoNewSize();
        DoDrawStuff()
      ELSIF msg.class = {i.gadgetDown} THEN
        currentGadget := gadget.gadgetID
      ELSIF msg.class = {i.gadgetUp} THEN
        CheckGadget (currentGadget);
        currentGadget := noGadget
      ELSIF msg.class = {i.intuiTicks} THEN
        CheckGadget (currentGadget)
      END;
      e.ReplyMsg (msg)
    END;
  END;
END DoMsgLoop;

(*------------------------------------*)
PROCEDURE SuperWindow (myScreen : i.ScreenPtr);

  VAR
    bigBitMap : gfx.BitMapPtr;
    planeNum : INTEGER;
    allocatedBitMaps : BOOLEAN;

BEGIN (* SuperWindow *)
  (* set-up the border prop gadgets for the OpenWindow() call. *)
  InitBorderProps (myScreen);

  (* The code relies on the allocation of the BitMap structure with
  ** the memClear flag.  This allows the assumption that all of the
  ** bitmap pointers are NIL, except those successfully allocated
  ** by the program.
  *)
  bigBitMap := e.AllocMem (SIZE (gfx.BitMap), {e.public, e.memClear});
  IF bigBitMap # NIL THEN
    gfx.InitBitMap
      ( bigBitMap^, myScreen.bitMap.depth, widthSuper, heightSuper );

    allocatedBitMaps := TRUE;
    planeNum := 0;
    WHILE (planeNum < myScreen.bitMap.depth) & allocatedBitMaps DO
      bigBitMap.planes [planeNum] :=
        gfx.AllocRaster (widthSuper, heightSuper);
      allocatedBitMaps := (bigBitMap.planes [planeNum] # NIL);
      INC (planeNum)
    END;

    (* Only open the window if the bitplanes were successfully
    ** allocated.  Fail silently if they were not.
    *)
    IF allocatedBitMaps THEN
      (* OpenWindowTags() and OpenWindowTagList() are only available
      ** when the lebrary version is at least V36.  Under earlier
      ** versions of Intuition, use OpenWindow() with a NewWindow
      ** structure.
      *)
      win := i.OpenWindowTagsA
        ( NIL,
          i.waWidth,     150,
          i.waHeight,    4 * (myScreen.wBorTop + myScreen.font.ySize + 1),
          i.waMaxWidth,  widthSuper,
          i.waMaxHeight, heightSuper,
          i.waIDCMP,     { i.gadgetUp, i.gadgetDown,
                           i.newSize, i.intuiTicks,
                           i.closeWindow },
          i.waFlags,     { i.windowSizing, i.sizeBRight,
                           i.sizeBBottom, i.windowDrag,
                           i.windowDepth, i.windowClose,
                           i.superBitmap, i.gimmeZeroZero,
                           i.noCareRefresh },
          i.waGadgets,     SYS.ADR (sideGad),
          i.waTitle,       SYS.VAL (LONGINT, SYS.ADR (VersionTag)) + 6,
          i.waPubScreen,   myScreen,
          i.waSuperBitMap, bigBitMap,
          0 );
      IF win # NIL THEN
        (* set-up the window display *)
        gfx.SetRast (win.rPort, 0);
        gfx.SetDrMd (win.rPort, gfx.jam1);
        DoNewSize (); (* adjust props to represent portion visible *)
        DoDrawStuff ();

        (* process the window, return on idcmpCloseWindow *)
        DoMsgLoop ();
        i.CloseWindow (win)
      END;
    END;
    FOR planeNum := 0 TO myScreen.bitMap.depth - 1 DO
      gfx.FreeRaster
        ( bigBitMap.planes [planeNum], widthSuper, heightSuper )
    END;
    e.FreeMem (bigBitMap, SIZE (gfx.BitMap))
  END;
END SuperWindow;

(*------------------------------------*)
PROCEDURE Main ();

  VAR
    myScreen : i.ScreenPtr;

BEGIN (* Main *)
  IF i.base.libNode.version >= 37 THEN
    myScreen := i.LockPubScreen ("");
    IF myScreen # NIL THEN
      SuperWindow (myScreen);
      i.UnlockPubScreen ("", myScreen);
    END
  END
END Main;

BEGIN (* Lines *)
  rn.TimeSeed ();
  Main ();
END Lines.