Fresh Fish 8/FreshFishVol8-CD2.bin/bbs/dev/oberon-a-1.4ß.lha/Oberon-A/source/amigautil/IntuiUtil.mod

Text File | 1994-08-08 | 17KB | 658 lines

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

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

   Created by: fjc (Frank Copeland)
    $Revision: 3.2 $
      $Author: fjc $
        $Date: 1994/08/08 16:09:54 $

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

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

MODULE IntuiUtil;

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

IMPORT
  E := Exec, G := Graphics, L := Layers, I := Intuition,
  U := Util, SYS := SYSTEM;


(* 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
  SYS.PUTREG (0, I.base.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 (*I.maxPot*) -1
      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 (*I.maxBody*) -1
  ELSE
    RETURN SHORT ((I.maxBody * visibleUnits) DIV totalUnits)
  END; (* ELSE *)
END ConvertToBody;


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

VAR
  stringInfo : I.StringInfoPtr;

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.base.IntuiTextLength(intuiText)) ) DIV 2 ) + left;
  intuiText.topEdge :=
    ( ( height - IntuiTextHeight(intuiText) ) DIV 2 ) + top;
END CentreIntuiText;


(*------------------------------------*)
(* $D- *)
PROCEDURE CalcTextBox *
  ( text              : ARRAY OF CHAR;
    font              : G.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;

BEGIN (* CalcTextBox *)
  intuiText.iText := SYS.ADR (text);
  intuiText.iTextFont := font;
  width := SHORT (I.base.IntuiTextLength (intuiText));
  height := IntuiTextHeight (intuiText);
END CalcTextBox;


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


(*------------------------------------*)
PROCEDURE ClipWindow *
  ( window                 : I.WindowPtr;
    minX, minY, maxX, maxY : INTEGER;
    VAR oldRegion          : G.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 : G.RegionPtr; myRectangle : G.Rectangle;

BEGIN (* ClipWindow *)
  myRectangle.minX := minX;
  myRectangle.minY := minY;
  myRectangle.maxX := maxX;
  myRectangle.maxY := maxY;
  newRegion := G.base.NewRegion();
  IF newRegion # NIL THEN
    IF G.base.OrRectRegion (newRegion, m