Fresh Fish 10/Fresh_Fish_10_2352.bin/new/dev/obero/oberon-a/examples/libraries/intuition/dualplayfield.mod

Text File | 1995-07-02 | 6KB | 217 lines

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

     $RCSfile: DualPlayfield.mod $
  Description: A port of dualplayfield.c in the RKM:Libraries.

               Shows how to turn on dual-playfield mode in a screen.

   Created by: fjc (Frank Copeland)
    $Revision: 1.4 $
      $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 DualPlayfield;

IMPORT SYS := SYSTEM, e := Exec, gfx := Graphics, i := Intuition;

CONST
  VersionTag = "$VER: DualPlayfield 1.3 (24.1.95)\r\n";
  VersionStr = "DualPlayfield 1.3 (23.1.95)\r\n";
  CopyrightStr = "Copyright © 1994-1995 Frank Copeland";

(*------------------------------------
** Manhandle the viewport:
** install second playfield and change modes
*)
PROCEDURE InstallDualPF
  ( scrn : i.ScreenPtr; rinfo2 : gfx.RasInfoPtr )
  : BOOLEAN;

  VAR
    screenModeID : LONGINT;
    returnCode : BOOLEAN;

BEGIN (* InstallDualPF *)
  screenModeID := gfx.GetVPModeID (SYS.ADR (scrn.viewPort));
  IF screenModeID # gfx.invalidID THEN
    (* You can only play with the bits in the modes field
    ** if the upper half of the screen mode ID is zero!!!
    *)
    IF SYS.AND (screenModeID, 0FFFF0000H) = 0 THEN
      returnCode := TRUE;
      e.Forbid();
        (* Install rinfo for viewport's second playfield *)
        scrn.viewPort.rasInfo.next := rinfo2;
        INCL (scrn.viewPort.modes, gfx.dualpf);
      e.Permit();
      (* Put viewport change into effect *)
      i.MakeScreen (scrn);
      i.RethinkDisplay ();
    END
  END;
  RETURN returnCode
END InstallDualPF;

(*------------------------------------*)
(* Draw some lines in a rastport...This is used to get some data into
** the second playfield.  The windows on the screen will move underneath
** these graphics without disturbing them.
*)
PROCEDURE DrawSomething (rp : gfx.RastPortPtr);

  VAR
    width, height : INTEGER;
    r, c : INTEGER;

BEGIN (* DrawSomething *)
  width := rp.bitMap.bytesPerRow * 8;
  height := rp.bitMap.rows;
  gfx.SetAPen (rp, 1);
  FOR r := 0 TO height - 1 BY 40 DO
    FOR c := 0 TO width - 1 BY 40 DO
      gfx.Move (rp, 0, r);
      gfx.Draw (rp, c, 0)
    END
  END
END DrawSomething;

(*------------------------------------*)
(* simple event loop to wait for the user to hit the close gadget
** on the window.
*)
PROCEDURE HandleIDCMP (win : i.WindowPtr);

  VAR
    done    : BOOLEAN;
    message : i.IntuiMessagePtr;
    class   : SET;
    signals : SET;

BEGIN (* HandleIDCMP *)
  done := FALSE;
  WHILE ~done DO
    signals := e.Wait ({win.userPort.sigBit});
    IF win.userPort.sigBit IN signals THEN
      LOOP
        message :=
          SYS.VAL (i.IntuiMessagePtr, e.GetMsg (win.userPort));
        IF message = NIL THEN EXIT END;
        class := message.class;
        e.ReplyMsg (message);
        IF class = {i.closeWindow} THEN
          done := TRUE
        END;
        IF done THEN EXIT END;
      END
    END
  END
END HandleIDCMP;

(*------------------------------------*)
(* remove the effects of InstallDualPF();
** only call if InstallDualPF() succeeded.
*)
PROCEDURE RemoveDualPF (scrn : i.ScreenPtr);

BEGIN (* RemoveDualPF *)
  e.Forbid();
    scrn.viewPort.rasInfo.next := NIL;
    EXCL (scrn.viewPort.modes, gfx.dualpf);
  e.Permit();
  i.MakeScreen (scrn);
  i.RethinkDisplay ();
END RemoveDualPF;

(*------------------------------------*)
PROCEDURE DoDualPF (win : i.WindowPtr);

  VAR
    myScreen : i.ScreenPtr;
    rinfo2   : gfx.RasInfoPtr;
    bmap2    : gfx.BitMapPtr;
    rport2   : gfx.RastPortPtr;

BEGIN (* DoDualPF *)
  myScreen := win.wScreen; (* Find the window's screen *)

  (* Allocate the second playfield's rasinfo, bitmap, and bitplane *)
  rinfo2 := e.AllocMem (SIZE (gfx.RasInfo), {e.public, e.memClear});
  IF rinfo2 # NIL THEN
    (* Get a rastport, and set it up for rendering into bmap2 *)
    rport2 := e.AllocMem (SIZE (gfx.RastPort), {e.public});
    IF rport2 # NIL THEN
      bmap2 := e.AllocMem (SIZE (gfx.BitMap), {e.public, e.memClear});
      IF bmap2 # NIL THEN
        gfx.InitBitMap (bmap2^, 1, myScreen.width, myScreen.height);
        (* extra playfield will only use one bitplane here. *)
        bmap2.planes [0] :=
          gfx.AllocRaster (myScreen.width, myScreen.height);
        IF bmap2.planes [0] # NIL THEN
          gfx.InitRastPort (rport2^);
          rinfo2.bitMap := bmap2; rport2.bitMap := bmap2;
          gfx.SetRast (rport2, 0);
          IF InstallDualPF (myScreen, rinfo2) THEN
            (* Set foreground color; color 9 is color 1 for
            ** second playfield of hi-res viewport.
            *)
            gfx.SetRGB4 (SYS.ADR (myScreen.viewPort), 9, 0, 0FH, 0);
            DrawSomething (rport2);
            HandleIDCMP (win);
            RemoveDualPF (myScreen);
          END;
          gfx.FreeRaster
            (bmap2.planes [0], myScreen.width, myScreen.height)
        END;
        e.FreeMem (bmap2, SIZE (gfx.BitMap))
      END;
      e.FreeMem (rport2, SIZE (gfx.RastPort))
    END;
    e.FreeMem (rinfo2, SIZE (gfx.RasInfo))
  END;
END DoDualPF;

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

  VAR
    win : i.WindowPtr;
    scr : i.ScreenPtr;

BEGIN (* Main *)
  scr := i.OpenScreenTagsA
    ( NIL,
      i.saDepth,     2,
      i.saDisplayID, gfx.hiresKey,
      i.saTitle,     SYS.ADR ("Dual Playfield Test Screen"),
      0 );
  IF scr # NIL THEN
    win := i.OpenWindowTagsA
      ( NIL,
        i.waTitle,        SYS.ADR ("Dual Playfield Mode"),
        i.waIDCMP,        {i.closeWindow},
        i.waWidth,        200,
        i.waHeight,       100,
        i.waDragBar,      1,
        i.waCloseGadget,  1,
        i.waCustomScreen, scr,
        0 );
    IF win # NIL THEN
      DoDualPF (win);
      i.CloseWindow (win)
    END;
    i.OldCloseScreen (scr)
  END;
END Main;

BEGIN (* DualPlayfield *)
  Main ();
END DualPlayfield.