BCI NET 2/BCI NET 2.iso/archives/programming/languages/obrn-a_1.5_lib.lha/oberon-a/source2.lha/Source/Library/XYPlane.mod

Text File | 1995-01-26 | 9.2 KB | 367 lines

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

     $RCSfile: XYPlane.mod $
  Description: Basic facilities for graphics programming.

   Created by: fjc (Frank Copeland)
    $Revision: 1.3 $
      $Author: fjc $
        $Date: 1995/01/26 00:40:27 $

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

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

<* STANDARD- *> <* MAIN- *>

MODULE XYplane;

IMPORT
  SYS := SYSTEM, Kernel, e := Exec, es := ExecSupport, u := Utility,
  gfx := Graphics, i := Intuition, gt := GadTools, str := Strings,
  s := Sets;

CONST
  draw *= 1;
  erase *= 0;

VAR
  X -, Y -, W -, H -: INTEGER;

CONST
  pubScreenName = "";
  drawPen = 1;
  erasePen = 0;

VAR
  scr : i.ScreenPtr;
  scrDepth : INTEGER;
  win : i.WindowPtr;
  winLock : e.SignalSemaphore;
  winTask : e.TaskPtr;
  keyPressed : CHAR;

CONST

  (* Menu and menu item indices. *)

  menuXYplane = 0;
    itemAbout = 0;
    itemBar = 1;
    itemClose = 2;

  numMenus = 4;

VAR
  menus : ARRAY numMenus + 1 OF gt.NewMenu;
  menuStrip : i.MenuPtr;
  visInfo : gt.VisualInfo;


PROCEDURE OpenScreen ();

  VAR
    screenModeID : LONGINT;
    pubScreen : i.ScreenPtr;
    screenDrawInfo : i.DrawInfoPtr;

BEGIN (* OpenScreen *)
  pubScreen := i.LockPubScreen (pubScreenName);
  IF pubScreen # NIL THEN
    (*
    ** Get the DrawInfo structure from the locked screen
    ** This returns pen, depth and font info.
    *)
    screenDrawInfo := i.GetScreenDrawInfo (pubScreen);
    IF screenDrawInfo # NIL THEN
      screenModeID := gfx.GetVPModeID (SYS.ADR (pubScreen.viewPort));
      IF screenModeID # gfx.invalidID THEN
        (*
        ** screenModeID may now be used in a call to
        ** OpenScreenTags () with the tag saDisplayID
        *)
        scrDepth := screenDrawInfo.depth;
        scr := i.OpenScreenTagsA ( NIL,
            i.saWidth,       pubScreen.width,
            i.saHeight,      pubScreen.height,
            i.saDepth,       screenDrawInfo.depth,
            i.saOverscan,    i.oScanText,
            i.saAutoScroll,  i.LTRUE,
            i.saFullPalette, i.LTRUE,
            i.saPens,        screenDrawInfo.pens,
            i.saSysFont,     1,
            i.saDisplayID,   screenModeID,
            i.saTitle,       SYS.ADR ("XYplane inactive"),
            u.end );
        IF scr # NIL THEN
          (*
          ** Free the drawinfo an public screen as we don't
          ** need them any more. We now have our own screen.
          *)
          i.FreeScreenDrawInfo (pubScreen, screenDrawInfo);
          screenDrawInfo := NIL;
          i.UnlockPubScreen (pubScreenName, pubScreen);
          pubScreen := NIL;

          (*
          ** Obtain a VisualInfo for creating menus, etc.
          *)
          visInfo := gt.GetVisualInfo (scr, u.end);
          IF visInfo = NIL THEN i.OldCloseScreen (scr); scr := NIL END
        END
      END
    END
  END
END OpenScreen;


PROCEDURE CloseScreen ();
BEGIN (* CloseScreen *)
  IF visInfo # NIL THEN gt.FreeVisualInfo (visInfo); visInfo := NIL END;
  IF scr # NIL THEN i.OldCloseScreen (scr); scr := NIL END;
END CloseScreen;


PROCEDURE OpenWindow ();
BEGIN (* OpenWindow *)
  win := i.OpenWindowTagsA ( NIL,
      i.waCustomScreen, scr,
      i.waTop,          scr.barHeight + 1,
      i.waHeight,       scr.height - scr.barHeight - 1,
      i.waActivate,     i.LTRUE,
      i.waBorderless,   i.LTRUE,
      i.waBackdrop,     i.LTRUE,
      i.waScreenTitle,  SYS.ADR ("XYplane active"),
      u.end );
END OpenWindow;


PROCEDURE CloseWindow ();
BEGIN (* CloseWindow *)
  IF win # NIL THEN i.CloseWindow (win); win := NIL END;
END CloseWindow;


PROCEDURE AddMenus ();

BEGIN (* AddMenus *)
  (* Making the assumption that unitialised fields are zeroed... *)
  menus[0].type := gt.title;
  menus[0].label := SYS.ADR ("XYplane");

  menus[1].type := gt.item;
  menus[1].label := SYS.ADR ("About...");

  menus[2].type := gt.item;
  menus[2].label := gt.barLabel;

  menus[3].type := gt.item;
  menus[3].label := SYS.ADR ("Close...");
  menus[3].commKey := SYS.ADR ("Q");
END AddMenus;


PROCEDURE RemoveMenus ();
BEGIN (* RemoveMenus *)
  IF menuStrip # NIL THEN
    i.ClearMenuStrip (win);
    gt.FreeMenus (menuStrip); menuStrip := NIL
  END;
END RemoveMenus;


PROCEDURE* HandleWindow ();

  VAR
    msg : i.IntuiMessagePtr;
    done : BOOLEAN;
    menuNumber : INTEGER;
    menuNum : INTEGER;
    itemNum : INTEGER;
    subNum : INTEGER;
    item : i.MenuItemPtr;
    signals : s.SET32;
    sigBit : SHORTINT;

  PROCEDURE ShowAbout ();

    VAR es : i.EasyStruct; ignore : LONGINT;

  BEGIN (* ShowAbout *)
    es.structSize := SIZE (i.EasyStruct);
    es.flags := {};
    es.title := SYS.ADR ("About XYplane");
    es.textFormat :=
      SYS.ADR ( "XYplane for Oberon-A\n"
                "Written by Frank Copeland\n"
                "XYplane 1.1 (16.10.94)" );
    es.gadgetFormat := SYS.ADR ("Continue");
    ignore := i.EasyRequest ( win, SYS.ADR (es), NIL, NIL )
  END ShowAbout;


BEGIN (* HandleWindow *)
  e.ObtainSemaphore (winLock);
    i.OldModifyIDCMP (win, {i.menuPick, i.vanillaKey});
    sigBit := win.userPort.sigBit;
  e.ReleaseSemaphore (winLock);

  done := FALSE;
  WHILE ~done DO
    (* We only have one signal bit, so we do not have to check which
    ** bit broke the Wait().
    *)
    signals := e.Wait ({sigBit});
    e.ObtainSemaphore (winLock);
      LOOP
        IF done THEN EXIT END;
        msg := SYS.VAL (i.IntuiMessagePtr, e.GetMsg (win.userPort));
        IF msg = NIL THEN EXIT END;
        IF msg.class = {i.menuPick} THEN
          menuNumber := msg.code;
          WHILE (menuNumber # i.menuNull) & ~done DO
            item := i.ItemAddress (menuStrip^, menuNumber);

            (* Process the item here *)
            menuNum := i.MenuNum (menuNumber);
            itemNum := i.ItemNum (menuNumber);
            subNum := i.SubNum (menuNumber);

            CASE menuNum OF
              menuXYplane :
                CASE itemNum OF
                  itemAbout : ShowAbout() |
                  itemClose : done := TRUE |
                END
              |
            END;

            menuNumber := item.nextSelect
          END
        ELSIF msg.class = {i.vanillaKey} THEN
          keyPressed := CHR (msg.code)
        END;
        e.ReplyMsg (msg)
      END;
    e.ReleaseSemaphore (winLock);
  END;

  (* Close the window and screen *)
  e.ObtainSemaphore (winLock);
    RemoveMenus();
    CloseWindow();
    CloseScreen();
  e.ReleaseSemaphore (winLock);

  (* Put task in a safe state until removed by the main process. *)
  signals := e.Wait ({});
END HandleWindow;


PROCEDURE Open *;
BEGIN (* Open *)
  IF scr = NIL THEN
    OpenScreen(); ASSERT (scr # NIL, 98);
    OpenWindow(); ASSERT (win # NIL, 98);
    AddMenus(); ASSERT (menuStrip # NIL, 98);
    X := 0; Y := 0;
    W := win.width - win.borderLeft - win.borderRight;
    H := win.height - win.borderTop - win.borderBottom;
    keyPressed := 0X;
    e.InitSemaphore (winLock);
    IF winTask # NIL THEN es.DeleteTask (winTask) END;
    winTask := es.CreateTask ("", 0, HandleWindow, 4000);
    ASSERT (winTask # NIL, 98)
  END
END Open;


PROCEDURE Clear *;

BEGIN (* Clear *)
  e.ObtainSemaphore (winLock);
    IF win # NIL THEN
      gfx.SetRast (win.rPort, erasePen);
      i.RefreshWindowFrame (win)
    END;
  e.ReleaseSemaphore (winLock);
END Clear;


PROCEDURE Dot * ( x, y, mode : INTEGER );

  VAR rp : gfx.RastPortPtr;

BEGIN (* Dot *)
  ASSERT ((x >= 0) & (y >= 0) & ((mode = draw) OR (mode = erase)), 97);
  e.ObtainSemaphore (winLock);
    IF win # NIL THEN
      (* Map Oberon co-ordinates to window co-ordinates *)
      x := x + win.borderLeft;
      y := win.height - win.borderBottom - y - 1;
      (* Clip to window boundaries *)
      IF (x < (win.width - win.borderRight)) & (y > win.borderTop) THEN
        rp := win.rPort;
        IF mode = draw THEN gfx.SetAPen (rp, drawPen)
        ELSE gfx.SetAPen (rp, erasePen)
        END;
        gfx.SetDrMd (rp, gfx.jam1);
        IF gfx.WritePixel (rp, x, y) THEN END;
      END;
    END;
  e.ReleaseSemaphore (winLock);
END Dot;


PROCEDURE IsDot * ( x, y : INTEGER ) : BOOLEAN;

  VAR result : BOOLEAN;

BEGIN (* IsDot *)
  ASSERT ((x >= 0) & (y >= 0), 97);
  result := FALSE;
  e.ObtainSemaphore (winLock);
    IF win # NIL THEN
      (* Map Oberon co-ordinates to window co-ordinates *)
      x := x + win.borderLeft;
      y := win.height - win.borderBottom - y - 1;
      (* Clip to window boundaries *)
      IF (x < (win.width - win.borderRight)) & (y > win.borderTop) THEN
        result := gfx.ReadPixel (win.rPort, x, y) # erasePen
      END
    END;
  e.ReleaseSemaphore (winLock);
  RETURN result
END IsDot;


PROCEDURE Key * () : CHAR;

  VAR ch : CHAR;

BEGIN (* Key *)
  IF scr = NIL THEN Open() END;
  ch := keyPressed; keyPressed := 0X;
  RETURN ch
END Key;


PROCEDURE* Close ( VAR rc : LONGINT );
BEGIN (* Close *)
  e.ObtainSemaphore (winLock);
    IF winTask # NIL THEN es.DeleteTask (winTask); winTask := NIL END;
    RemoveMenus();
    CloseWindow();
    CloseScreen();
  e.ReleaseSemaphore (winLock);
END Close;

<*$ClearVars+*>
BEGIN
  ASSERT (gt.base # NIL, 100);
  e.InitSemaphore (winLock);
  Kernel.SetCleanup (Close)
END XYplane.