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

Text File | 1995-01-26 | 16.4 KB | 659 lines

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

     $RCSfile: IntuiUtil.mod $
  Description: Support for clients of intuition.library

   Created by: fjc (Frank Copeland)
    $Revision: 3.7 $
      $Author: fjc $
        $Date: 1995/01/26 00:30:04 $

  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- *> <* INITIALISE- *> <* MAIN- *>
<*$ CaseChk-  IndexChk- LongVars+ NilChk-  *>
<*$ RangeChk- StackChk- TypeChk-  OvflChk- *>

MODULE IntuiUtil;

IMPORT
  SYS := SYSTEM, e := Exec, gfx := Graphics, l := Layers, i := Intuition,
  u := Util;


(* Passed as a parameter to GetMenuChoice () *)

TYPE

  Choice * = RECORD
    menuChosen *    : INTEGER;
    itemChosen *    : INTEGER;
    subItemChosen * : INTEGER;
    pointer *       : i.MenuItemPtr;
  END; (* ChoiceType *)

CONST

  halfPot  = i.maxPot DIV 2;
  halfBody = i.maxBody DIV 2;

VAR
  autoIntuiText : i.IntuiText;


(* ===== Preferences ===== *)


(*------------------------------------*)
PROCEDURE PrefsFontHeight * () : SHORTINT;
(*
  Returns the height of the default system font.
*)

VAR
  prefsBuffer : i.Preferences;

BEGIN
  i.GetPrefs (prefsBuffer, SIZE(i.Preferences));
  RETURN prefsBuffer.fontHeight;
END PrefsFontHeight;


(* ===== Gadget ===== *)


(*------------------------------------*)
PROCEDURE CentreGadget *
  ( VAR gadget : i.Gadget; left, top, width, height : INTEGER );
(*
  Adjusts the gadget's position to centre it within a rectangle defined by
  (left, top, width, height).
*)

BEGIN (* CentreGadget *)
  gadget.leftEdge := ( ( width - gadget.width ) DIV 2 ) + left;
  gadget.topEdge := ( ( height - gadget.height ) DIV 2 ) + top;
END CentreGadget;


(*------------------------------------*)
PROCEDURE ConvertPot *
  ( potValue, totalUnits, visibleUnits : INTEGER )
  : INTEGER;

VAR
  value, hidden : LONGINT;

BEGIN (* ConvertPot *)
  IF (potValue = 0) THEN
    RETURN 0
  ELSE
    IF (visibleUnits >= totalUnits) THEN
      RETURN 0
    ELSE
      IF potValue < 0 THEN value := potValue + 010000H
      ELSE value := potValue
      END;
      hidden := totalUnits - visibleUnits;
      RETURN SHORT ((hidden * value + halfPot) DIV i.maxPot)
    END; (* ELSE *)
  END; (* ELSE *)
END ConvertPot;


(*------------------------------------*)
PROCEDURE ConvertToPot *
  ( units, totalUnits, visibleUnits : INTEGER )
  : INTEGER;

VAR
  hidden, lUnits : LONGINT;

BEGIN (* ConvertToPot *)
  IF units = 0 THEN
    RETURN 0
  ELSE
    IF visibleUnits >= totalUnits THEN
      RETURN 0
    ELSE
      IF units < 0 THEN lUnits := units + 010000H
      ELSE lUnits := units
      END;
      hidden := totalUnits - visibleUnits;
      IF lUnits >= hidden THEN
        RETURN -1 (*i.maxPot*)
      ELSE
        RETURN SHORT ((i.maxPot * lUnits) DIV hidden)
      END; (* ELSE *)
    END; (* ELSE *)
  END; (* ELSE *)
END ConvertToPot;


(*------------------------------------*)
PROCEDURE ConvertBody * (bodyValue, totalUnits : INTEGER) : INTEGER;

  VAR value : LONGINT;

BEGIN (* ConvertBody *)
  IF bodyValue = 0 THEN
    RETURN 0
  ELSIF (bodyValue = i.maxBody) OR (totalUnits < 2) THEN
    RETURN totalUnits
  ELSE
    IF bodyValue < 0 THEN value := bodyValue + 010000H
    ELSE value := bodyValue
    END;
    RETURN SHORT ((totalUnits * value) DIV i.maxBody);
  END
END ConvertBody;


(*------------------------------------*)
PROCEDURE ConvertToBody * ( totalUnits, visibleUnits : INTEGER ) : INTEGER;

BEGIN (* ConvertToBody *)
  IF visibleUnits = 0 THEN
    RETURN 0
  ELSIF visibleUnits >= totalUnits THEN
    RETURN -1 (*i.maxBody*)
  ELSE
    RETURN SHORT ((i.maxBody * visibleUnits) DIV totalUnits)
  END; (* ELSE *)
END ConvertToBody;


(*------------------------------------*)
PROCEDURE SetString * (VAR gadget : i.Gadget; string : ARRAY OF CHAR);

VAR
  stringInfo : i.StringInfoPtr;

<*$CopyArrays-*>
BEGIN (* SetString *)
  stringInfo := SYS.VAL (i.StringInfoPtr, gadget.specialInfo);
  SYS.MOVE
    ( SYS.ADR (string), stringInfo.buffer,
      u.MaxInt
        ( SHORT (SYS.STRLEN (string) + 1), stringInfo.maxChars - 1 ) );
  stringInfo.buffer [stringInfo.maxChars] := 0X
END SetString;


(*------------------------------------*)
PROCEDURE GetString *  (VAR gadget : i.Gadget; VAR string : ARRAY OF CHAR);

VAR
  stringInfo : i.StringInfoPtr;

BEGIN (* SetString *)
  stringInfo := SYS.VAL (i.StringInfoPtr, gadget.specialInfo);
  COPY (stringInfo.buffer^, string)
END GetString;


(*------------------------------------*)
PROCEDURE SetInteger * ( VAR gadget : i.Gadget; integer : LONGINT );

  VAR
    stringInfo : i.StringInfoPtr;
    buffer : ARRAY 12 OF CHAR;
    index : INTEGER;
    negative : BOOLEAN;

  (*------------------------------------*)
  PROCEDURE Digits ( integer : LONGINT ) : INTEGER;

  VAR
    digits : INTEGER;

  BEGIN (* Digits *)
    digits := 0;
    WHILE ( integer > 0 ) DO
      INC( digits );
      integer := integer DIV 10;
    END; (* WHILE *)
    RETURN digits;
  END Digits;

BEGIN (* SetInteger *)
  stringInfo := SYS.VAL (i.StringInfoPtr, gadget.specialInfo);
  stringInfo.longInt := integer;
  negative := (integer < 0); integer := ABS(integer);
  index := Digits( integer );
  IF negative THEN INC(index) END;
  buffer [index] := 0X;
  WHILE integer > 0 DO
    DEC (index);
    buffer[index] := CHR (integer MOD 10 + ORD ("0"));
    integer := integer DIV 10;
  END; (* WHILE *)
  IF negative THEN buffer [0] := "-" END;
  SetString (gadget, buffer);
END SetInteger;


(*------------------------------------*)
PROCEDURE GetInteger * ( VAR gadget : i.Gadget ) : LONGINT;

VAR
  stringInfo : i.StringInfoPtr;

BEGIN (* GetInteger *)
  stringInfo := SYS.VAL (i.StringInfoPtr, gadget.specialInfo);
  RETURN stringInfo^.longInt;
END GetInteger;


(* ===== IntuiText ===== *)


(*------------------------------------*)
PROCEDURE IntuiTextHeight * ( VAR intuiText : i.IntuiText ) : INTEGER;
(*
  Returns the height in scan lines of the text held in intuiText.
*)

BEGIN (* IntuiTextHeight *)
  IF intuiText.iTextFont = NIL THEN
    RETURN PrefsFontHeight()
  ELSE
    RETURN intuiText.iTextFont.ySize
  END; (* ELSE *)
END IntuiTextHeight;


(*------------------------------------*)
PROCEDURE CentreIntuiText * (
  VAR intuiText : i.IntuiText;
  left, top, width, height : INTEGER );
(*
  Adjusts the text's position to centre it within a rectangle defined by
  (left, top, width, height).
*)

BEGIN (* CentreIntuiText *)
  intuiText.leftEdge :=
    ( ( width - SHORT (i.IntuiTextLength(intuiText)) ) DIV 2 ) + left;
  intuiText.topEdge :=
    ( ( height - IntuiTextHeight(intuiText) ) DIV 2 ) + top;
END CentreIntuiText;


(*------------------------------------*)
PROCEDURE CalcTextBox *
  ( text              : ARRAY OF CHAR;
    font              : gfx.TextAttrPtr;
    VAR width, height : INTEGER );
(*
  Returns the minimum size of the rectangle that will enclose the given text
  if rendered in the given font.
*)

VAR
  intuiText : i.IntuiText;

<*$CopyArrays-*>
BEGIN (* CalcTextBox *)
  intuiText.iText := SYS.ADR (text);
  intuiText.iTextFont := font;
  width := SHORT (i.IntuiTextLength (intuiText));
  height := IntuiTextHeight (intuiText);
END CalcTextBox;


(* ===== Window ===== *)


(*------------------------------------*)
PROCEDURE ClipWindow *
  ( window                 : i.WindowPtr;
    minX, minY, maxX, maxY : INTEGER;
    VAR oldRegion          : gfx.RegionPtr )
  : BOOLEAN;
(*
  Sets up the window's clipping region to permit drawing only inside the
  rectangle defined by (minX, minY, maxX, maxY). It returns FALSE if the
  attempt fails and puts the existing clipping region in oldRegion.  It
  should immediately be followed by drawing routines, then
  UnclipWindow( window, oldRegion ).
*)

VAR
  newRegion : gfx.RegionPtr; myRectangle : gfx.Rectangle;

BEGIN (* ClipWindow *)
  myRectangle.minX := minX;
  myRectangle.minY := minY;
  myRectangle.maxX := maxX;
  myRectangle.maxY := maxY;
  newRegion := gfx.NewRegion();
  IF newRegion # NIL THEN
    IF gfx.OrRectRegion (newRegion, myRectangle) THEN
      oldRegion := l.InstallClipRegion (window.wLayer, newRegion);
      RETURN TRUE;
    END
  END;
  IF newRegion # NIL THEN
    gfx.DisposeRegion (newRegion);
  END;
  RETURN FALSE;
END ClipWindow;


(*------------------------------------*)
PROCEDURE ClipWindowToBorders *
  ( window : i.WindowPtr; VAR oldRegion : gfx.RegionPtr )
  : BOOLEAN;
(*
  Sets up the window's clipping region to permit drawing only inside the
  rectangle defined by the window's borders.  It returns FALSE if the
  attempt fails and puts the existing clipping region in oldRegion.  It
  should immediately be followed by drawing routines, then
  UnclipWindow( window, oldRegion ).
*)

BEGIN (* ClipWindowToBorders *)
  RETURN
    ClipWindow
      ( window, window.borderLeft, window.borderTop,
        window.width - window.borderRight - 1,
        window.height - window.borderBottom - 1, oldRegion );
END ClipWindowToBorders;


(*------------------------------------*)
PROCEDURE UnclipWindow * (window : i.WindowPtr; prevRegion : gfx.RegionPtr);
(*
  Restores a window's clipping region after a call to ClipWindow() or
  ClipWindowToBorders();
*)

VAR
  oldRegion : gfx.RegionPtr;

BEGIN (* UnclipWindow *)
  oldRegion := l.InstallClipRegion (window.wLayer, prevRegion);
  IF oldRegion # NIL THEN
    gfx.DisposeRegion (oldRegion);
  END
END UnclipWindow;


(*------------------------------------*)
PROCEDURE DrawWidth * ( window : i.WindowPtr ) : INTEGER;
(*
  Returns the width of the window's inner drawing region.
*)

BEGIN
  RETURN (window.width - window.borderLeft - window.borderRight)
END DrawWidth;


(*------------------------------------*)
PROCEDURE DrawHeight *
  ( window : i.WindowPtr )
  : INTEGER;
(*
  Returns the height of the window's inner drawing region.
*)

BEGIN
  RETURN (window.height - window.borderTop - window.borderBottom)
END DrawHeight;


(*------------------------------------*)
PROCEDURE AdjustForBorders *
  ( window : i.WindowPtr; VAR left, top : INTEGER );
(*
  Adjusts a window co-ordinate to ensure the origin is the top left of the
  window's inner drawing region.
*)

BEGIN (* AdjustForBorders *)
  IF ~(i.gimmeZeroZero IN window.flags) THEN
    INC( left, window.borderLeft); INC( top, window.borderTop)
  END
END AdjustForBorders;


(*------------------------------------*)
PROCEDURE StripIntuiMessages *
  ( mp : e.MsgPortPtr; win : i.WindowPtr );
(*
  Function to remove and reply all IntuiMessages on a port that have
  been sent to a particular window (note that we don't rely on the
  lnSucc pointer of a message after we have replied it).

  This is from the RKM:Libraries, 3d Ed, p255.
*)

  VAR msg : i.IntuiMessagePtr; succ : e.NodePtr;

BEGIN (* StripIntuiMessages *)
  msg := SYS.VAL (i.IntuiMessagePtr, mp.msgList.head);
  WHILE msg.execMessage.node.succ # NIL DO
    succ := msg.execMessage.node.succ;
    IF msg.idcmpWindow = win THEN
      (*
        Intuition is about to free this message.  Make sure that we have
        politely sent it back.
      *)
      e.Remove (msg);
      e.ReplyMsg (msg)
    END;
    msg := SYS.VAL (i.IntuiMessagePtr, succ)
  END
END StripIntuiMessages;

(*------------------------------------*)
PROCEDURE CloseWindowSafely *
  ( win : i.WindowPtr );
(*
  Strip all IntuiMessages from an IDCMP which are waiting for a specific
  window.  When the messages are gone, set the UserPort of the window to
  NIL and call ModifyIDCMP (win, {}).  This will free the Intuition
  parts of the IDCMP and turn off messages to this port without changing
  the original UserPort (which may be in use by other windows).

  This is from the RKM:Libraries, 3d Ed, p255.
*)

  VAR

BEGIN (* CloseWindowSafely *)
  (* We forbid here to keep out of race conditions with Intuition *)
  e.Forbid ();

  (*
    Send back any messages for this window that have not yet been processed
  *)
  StripIntuiMessages (win.userPort, win);

  (* Clear UserPort so Intuition will not free it *)
  win.userPort := NIL;

  (* Tell Intuition to stop sending messages *)
  i.OldModifyIDCMP (win, {});

  (* Turn multitasking back on *)
  e.Permit ();

  (* Now it's safe to really close the window *)
  i.CloseWindow (win)
END CloseWindowSafely;

(*------------------------------------*)
PROCEDURE FindSizeGadget *
  ( win : i.WindowPtr; VAR width, height : INTEGER )
  : BOOLEAN;

  CONST
    Sizing = i.sysGadget + i.sizing;

  VAR gadget : i.GadgetPtr;

BEGIN (* FindSizeGadget *)
  gadget := win.firstGadget;
  WHILE (gadget # NIL) & (gadget.gadgetType # Sizing) DO
    gadget := gadget.nextGadget
  END;
  IF gadget # NIL THEN
    width := gadget.width; height := gadget.height
  END;
  RETURN (gadget # NIL)
END FindSizeGadget;

(* ===== Requesters ===== *)

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

<*$LongVars-*>

PROCEDURE MultiRequest *
  ( window                     : i.WindowPtr;
    VAR bodyText               : ARRAY OF e.APTR;
    lines                      : INTEGER;
    positiveText, negativeText : e.APTR )
  : BOOLEAN;

CONST
  NoFlags = {};
  ExtraWidth = 32;
  ExtraHeight = 22;

VAR
  newTextPtr, bodyTextPtr, positiveTextPtr, negTextPtr : i.IntuiTextPtr;
  positiveIntuiText, negativeIntuiText : i.IntuiText;
  textHeight, maxLength, width, height : INTEGER;
  memory : i.RememberPtr;
  result : BOOLEAN;

BEGIN (* MultiRequest *)
  IF (lines > 0) THEN
    IF positiveText # NIL THEN
      positiveIntuiText := autoIntuiText;
      positiveIntuiText.iText := positiveText;
      positiveTextPtr := SYS.ADR (positiveIntuiText);
    ELSE
      positiveTextPtr := NIL;
    END;
    IF negativeText # NIL THEN
      negativeIntuiText := autoIntuiText;
      negativeIntuiText.iText := negativeText;
      negTextPtr := SYS.ADR (negativeIntuiText);
    ELSE
      RETURN FALSE
    END;
    memory := NIL;
    bodyTextPtr := NIL;
    maxLength := 0;
    textHeight := PrefsFontHeight() + 1;
    height := ((lines + 2) * textHeight) + ExtraHeight;
    WHILE lines > 0 DO
      newTextPtr := i.AllocRemember (memory, SIZE(i.IntuiText), {});
      IF newTextPtr # NIL THEN
        DEC (lines);
        newTextPtr^ := autoIntuiText;
        INC (newTextPtr^.topEdge, lines * textHeight);
        newTextPtr.iText := bodyText [lines];
        newTextPtr.nextText := bodyTextPtr;
        maxLength :=
          u.MaxInt
            (maxLength, SHORT (i.IntuiTextLength(newTextPtr^)));
        bodyTextPtr := newTextPtr;
      ELSE
        i.FreeRemember (memory, e.LTRUE);
        RETURN FALSE;
      END
    END; (* WHILE *)
    width := maxLength + ExtraWidth;
    result :=
      i.AutoRequest
        ( window, bodyTextPtr, positiveTextPtr, negTextPtr, NoFlags,
          NoFlags, width, height );
    i.FreeRemember (memory, e.LTRUE);
    RETURN result;
  ELSE
    RETURN FALSE;
  END
END MultiRequest;

<*$LongVars+*>

(*------------------------------------*)
PROCEDURE SimpleRequest * (
  window                               : i.WindowPtr;
  bodyText, positiveText, negativeText : e.APTR )
  : BOOLEAN;

VAR
  bodyTextArray : ARRAY 1 OF e.APTR;

BEGIN (* SimpleRequest *)
  IF bodyText # NIL THEN
    bodyTextArray [0] := bodyText;
    RETURN
      MultiRequest (window, bodyTextArray, 1, positiveText, negativeText);
  ELSE
    RETURN FALSE;
  END
END SimpleRequest;


(*------------------------------------*)
PROCEDURE SimpleNotice *
  ( window : i.WindowPtr; bodyText : e.APTR );

BEGIN (* SimpleNotice *)
  SYS.PUTREG (0, SimpleRequest (window, bodyText, NIL, SYS.ADR("Continue")))
END SimpleNotice;


(*------------------------------------*)
PROCEDURE MultiNotice *
  ( window : i.WindowPtr; VAR bodyText : ARRAY OF e.APTR; lines : INTEGER );

BEGIN (* MultiNotice *)
  SYS.PUTREG
    (0, MultiRequest (window, bodyText, lines, NIL, SYS.ADR("Continue")))
END MultiNotice;


(* ===== Menus ===== *)


(*------------------------------------*)
PROCEDURE GetMenuChoice *
  ( menuSelection  : INTEGER;
    VAR firstMenu  : i.Menu;
    VAR menuChoice : Choice );

BEGIN (* GetMenuChoice *)
  menuChoice.menuChosen := (menuSelection MOD 32);
  menuChoice.itemChosen := (SYS.LSH (menuSelection, -5) MOD 64);
  menuChoice.subItemChosen := (SYS.LSH (menuSelection, -11) MOD 32);
  menuChoice.pointer := i.ItemAddress (firstMenu, menuSelection);
END GetMenuChoice;


<*$LongVars-*>

BEGIN (* IntuiUtil *)
  autoIntuiText.leftEdge  := i.autoLeftEdge;
  autoIntuiText.topEdge   := i.autoTopEdge;
  autoIntuiText.frontPen  := i.autoFrontPen;
  autoIntuiText.backPen   := i.autoBackPen;
  autoIntuiText.drawMode  := i.autoDrawMode;
  autoIntuiText.iTextFont := i.autoITextFont;
  autoIntuiText.iText     := NIL;
  autoIntuiText.nextText  := i.autoNextText;
END IntuiUtil.