Fresh Fish 8/FreshFishVol8-CD1.bin/useful/dev/obero/oberon-a/examples/libraries/intuition/doublebuffer.mod

Text File | 1994-08-08 | 5.7 KB | 214 lines

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

     $RCSfile: DoubleBuffer.mod $
  Description: Port of doublebuffer.c from the RKM:Libraries.

               Shows the use of a double-buffered screen.

   Created by: fjc (Frank Copeland)
    $Revision: 1.2 $
      $Author: fjc $
        $Date: 1994/08/08 16:55:25 $

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

  Log entries are at the end of the file.

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

MODULE DoubleBuffer;

(*
** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
** $V= OvflChk       $Z= ZeroVars
*)

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

CONST
  VersionTag = "\0$VER: DoubleBuffer 1.0 (16.6.94)\r\n";
  VersionStr = "DoubleBuffer 1.0 (16 Jun 1994)\r\n";
  CopyrightStr = "Copyright © 1994 Frank Copeland\n\n";

CONST

  (* characteristics of the screen *)
  scrWidth = 320;
  scrHeight = 200;
  scrDepth = 2;

VAR

  myBitMaps : ARRAY 2 OF gfx.BitMapPtr;

(*------------------------------------*)
PROCEDURE FreePlanes ( bitMap : gfx.BitMapPtr );

  VAR planeNum : INTEGER;

BEGIN (* FreePlanes *)
  FOR planeNum := 0 TO scrDepth - 1 DO
    IF bitMap.planes [planeNum] # NIL THEN
      gfx.base.FreeRaster (bitMap.planes [planeNum], scrWidth, scrHeight)
    END
  END
END FreePlanes;

(*------------------------------------*)
PROCEDURE SetupPlanes ( bitMap : gfx.BitMapPtr ) : BOOLEAN;

  VAR planeNum : INTEGER;

BEGIN (* SetupPlanes *)
  FOR planeNum := 0 TO scrDepth - 1 DO
    bitMap.planes [planeNum] :=
      gfx.base.AllocRaster (scrWidth, scrHeight);
    IF bitMap.planes [planeNum] # NIL THEN
      gfx.base.BltClear
        ( bitMap.planes [planeNum], (scrWidth DIV 8) * scrHeight, {0} )
    ELSE
      FreePlanes (bitMap);
      RETURN FALSE
    END
  END;
  RETURN TRUE
END SetupPlanes;

(*------------------------------------*)
PROCEDURE FreeBitMaps ();

BEGIN (* FreeBitMaps *)
  FreePlanes (myBitMaps [0]); myBitMaps [0] := NIL;
  FreePlanes (myBitMaps [1]); myBitMaps [0] := NIL
END FreeBitMaps;

(*------------------------------------*)
PROCEDURE SetupBitMaps () : BOOLEAN;

BEGIN (* SetupBitMaps *)
  NEW (myBitMaps [0]);
  NEW (myBitMaps [1]);
  gfx.base.InitBitMap (myBitMaps [0]^, scrDepth, scrWidth, scrHeight);
  gfx.base.InitBitMap (myBitMaps [1]^, scrDepth, scrWidth, scrHeight);
  IF SetupPlanes (myBitMaps [0]) THEN
    RETURN SetupPlanes (myBitMaps [1])
  END;
  RETURN FALSE
END SetupBitMaps;

(*------------------------------------*)
PROCEDURE RunDBuf (screen : i.ScreenPtr);

  VAR
    ktr, xpos, ypos : INTEGER;
    toggleFrame : INTEGER;

BEGIN (* RunDBuf *)
  toggleFrame := 0;
  gfx.base.SetAPen (SYS.ADR (screen.rastPort), 1);
  FOR ktr := 1 TO 199 DO
    (* Calculate a position to place the object, these
    ** calculations insure the object will stay on the screen
    ** given the range of ktr and the size of the object,
    *)
    xpos := ktr;
    IF (ktr MOD 100) >= 50 THEN
      ypos := 50 - (ktr MOD 50)
    ELSE
      ypos := ktr MOD 50
    END;

    (* switch the bitmap so that we are drawing into the correct place *)
    screen.rastPort.bitMap := myBitMaps [toggleFrame];
    screen.viewPort.rasInfo.bitMap := myBitMaps [toggleFrame];

    (* Draw the objects.
    ** Here we clear the old frame and draw a simple filled rectangle.
    *)
    gfx.base.SetRast (SYS.ADR (screen.rastPort), 0);
    gfx.base.RectFill
      (SYS.ADR (screen.rastPort), xpos, ypos, xpos+100, ypos+100);

    (* update the physical display to match the newly drawn bitmap *)
    i.base.MakeScreen (screen); (* Tell Intuition to do its stuff.      *)
    i.base.RethinkDisplay (); (* Intuition compatible MrgCop & LoadView *)
                              (*               it also does a WaitTOF() *)

    IF toggleFrame = 0 THEN toggleFrame := 1
    ELSE toggleFrame := 0
    END
  END
END RunDBuf;

(*------------------------------------*)
PROCEDURE* Cleanup ();

BEGIN (* Cleanup *)
  IF myBitMaps [0] # NIL THEN FreePlanes (myBitMaps [0]) END;
  IF myBitMaps [1] # NIL THEN FreePlanes (myBitMaps [1]) END;
END Cleanup;

(*------------------------------------*)
PROCEDURE Init ();

BEGIN (* Init *)
  myBitMaps [0] := NIL; myBitMaps [1] := NIL;
  SYS.SETCLEANUP (Cleanup);
END Init;

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

  VAR
    screen : i.ScreenPtr;
    myNewScreen : i.NewScreen;

BEGIN (* Main *)
  IF SetupBitMaps() THEN
    (* Open a simple quiet screen that is using the first
    ** of the two bitmaps.
    *)
    myNewScreen.leftEdge := 0;
    myNewScreen.topEdge := 0;
    myNewScreen.width := scrWidth;
    myNewScreen.height := scrHeight;
    myNewScreen.depth := scrDepth;
    myNewScreen.detailPen := 0;
    myNewScreen.blockPen := 1;
    myNewScreen.viewModes := {gfx.hires};
    myNewScreen.type := i.customScreen + {i.customBitmap, i.screenQuiet};
    myNewScreen.font := NIL;
    myNewScreen.defaultTitle := NIL;
    myNewScreen.gadgets := NIL;
    myNewScreen.customBitMap := myBitMaps [0];

    screen := i.base.OpenScreen (myNewScreen);
    IF screen # NIL THEN
      (* Indicate that the rastport is double buffered *)
      screen.rastPort.flags := {gfx.dBuffer};
      RunDBuf (screen);
      i.base.OldCloseScreen (screen)
    END;
  END;
END Main;

BEGIN (* DoubleBuffer *)
  Init ();
  Main ();
END DoubleBuffer.

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

  $Log: DoubleBuffer.mod $
  Revision 1.2  1994/08/08  16:55:25  fjc
  Release 1.4

  Revision 1.1  1994/06/17  18:17:33  fjc
  Initial revision

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