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

    :Program.    Menus.mod
    :Contents.   Support of Intuition pulldown-menus
    :Author.     Nicolas Benezan [bne]
    :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
    :Phone.      711/333679
    :Copyright.  Public Domain
    :Language.   Oberon
    :Translator. Amiga Oberon Compiler V1.16 [fbs]
    :History.    V1.0 [bne] 27.Jan.1990 (Modula-2 version)
    :History.    V2.0 [bne] 31.Aug.1990 (ported to Oberon)

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

MODULE Menus;

IMPORT e: Exec, g: Graphics, i: Intuition, ol: OberonLib, rq: Requests,
       s: SYSTEM;

VAR
  CommWidth* : INTEGER;
  CheckWidth*: INTEGER;
  StdHeight* : INTEGER;
  OutOfMem*  : ARRAY 24 OF CHAR;

TYPE
  String = ARRAY 80 OF CHAR;
  StringPtr = POINTER TO String;
  LinkPtr = POINTER TO LONGINT;

PROCEDURE FindLast (First: LONGINT): LONGINT;
  VAR
    Next: LinkPtr;
  BEGIN
    rq.Assert (First # NIL, "Undefined menu or item");
    Next:= First;
    WHILE Next^ # NIL DO
      Next:= Next^;
    END;
    RETURN Next
  END FindLast;

PROCEDURE AllocText* (Text: ARRAY OF CHAR): StringPtr;
  (* $CopyArrays- *)
  VAR
    TextPtr: StringPtr;
  BEGIN
    ol.New (TextPtr, LEN (Text));
    IF TextPtr # NIL THEN
      e.CopyMem (Text, TextPtr^, LEN (Text));
    END;
    RETURN TextPtr
  END AllocText;

PROCEDURE InitText (VAR TextPtr: i.IntuiTextPtr;
                        Text: ARRAY OF CHAR;
                        Flags: SET): BOOLEAN;
  (* $CopyArrays- *)
  CONST
    StdText = i.IntuiText (0, 1, g.jam2, 0, 1, NIL, NIL, NIL);
  BEGIN
    NEW (TextPtr);
    IF TextPtr # NIL THEN
      TextPtr^:= StdText;
      IF i.checkIt IN Flags THEN
        TextPtr.leftEdge:= CheckWidth;
      END;
      TextPtr.iText:= AllocText (Text);
      IF TextPtr.iText # NIL THEN
        RETURN TRUE
      END;
      DISPOSE (TextPtr);
    END;
    RETURN FALSE
  END InitText;

PROCEDURE AddMenuOk* (VAR MenuStrip: i.MenuPtr;
                          Name: ARRAY OF CHAR;
                          Tab: INTEGER;
                          Enabled: BOOLEAN): BOOLEAN;
  (* $CopyArrays- *)
  VAR
    NewMenu, LastMenu: i.MenuPtr;
    TextPtr: i.IntuiTextPtr;
  BEGIN
    NEW (NewMenu);
    IF NewMenu # NIL THEN
      IF InitText (TextPtr, Name, {}) THEN
        NewMenu.leftEdge := Tab + 3;
        NewMenu.topEdge  := 0;
        NewMenu.width    := i.IntuiTextLength (TextPtr) + 6;
        NewMenu.height   := StdHeight;
        IF Enabled THEN
          NewMenu.flags  := {i.menuEnabled};
        ELSE
          NewMenu.flags  := {};
        END;
        NewMenu.menuName := TextPtr.iText;
        NewMenu.firstItem:= NIL;
        DISPOSE (TextPtr);
        IF MenuStrip = NIL THEN
          MenuStrip:= NewMenu;
        ELSE
          LastMenu:= FindLast (MenuStrip);
          INC (NewMenu.leftEdge, LastMenu.leftEdge + LastMenu.width);
          LastMenu.nextMenu:= NewMenu;
        END;
        RETURN TRUE
      END;
      DISPOSE (NewMenu);
    END;
    RETURN FALSE
  END AddMenuOk;

PROCEDURE AddMenu* (VAR MenuStrip: i.MenuPtr;
                        Name: ARRAY OF CHAR;
                        Tab: INTEGER;
                        Enabled: BOOLEAN);
  (* $CopyArrays- *)
  BEGIN
    rq.Assert (AddMenuOk (MenuStrip, Name, Tab, Enabled),
               OutOfMem);
  END AddMenu;

PROCEDURE InitItem (VAR ItemPtr: i.MenuItemPtr;
                        Name: ARRAY OF CHAR;
                        LeftEdge: INTEGER;
                        Flags: SET;
                        Excl: LONGSET;
                        Cmd: CHAR): BOOLEAN;
  (* $CopyArrays- *)
  VAR
    NewItem, ItemLink: i.MenuItemPtr;
    Width: INTEGER;
  BEGIN
    NEW (NewItem);
    IF NewItem # NIL THEN
      IF InitText (NewItem.itemFill, Name, Flags) THEN
        Width:= i.IntuiTextLength (NewItem.itemFill);
        IF i.checkIt IN Flags THEN
          INC (NewItem.width, CheckWidth);
        END;
        NewItem.leftEdge:= LeftEdge;
        NewItem.topEdge := 0;
        NewItem.width   := Width;
        NewItem.height  := StdHeight;
        NewItem.flags   := Flags;
        NewItem.mutualExclude:= Excl;
        NewItem.command := Cmd;
        NewItem.subItem := NIL;
        NewItem.nextItem:= NIL;
        IF ItemPtr = NIL THEN
          ItemPtr:= NewItem;
        ELSE
          ItemLink:= ItemPtr;
          LOOP
            INC (NewItem.topEdge, StdHeight);
            IF ItemLink.nextItem = NIL THEN
              EXIT
            END;
            ItemLink:= ItemLink.nextItem;
          END;
          ItemLink.nextItem:= NewItem;
        END;
        RETURN TRUE
      END;
      DISPOSE (NewItem);
    END;
    RETURN FALSE
  END InitItem;

PROCEDURE AddItemOk* (MenuStrip: i.MenuPtr;
                      Name: ARRAY OF CHAR;
                      Flags: SET;
                      Excl: LONGSET;
                      Cmd: CHAR): BOOLEAN;
  (* $CopyArrays- *)
  VAR
    LastMenu: i.MenuPtr;
  BEGIN
    LastMenu:= FindLast (MenuStrip);
    RETURN InitItem (LastMenu.firstItem, Name, 0, Flags, Excl, Cmd)
  END AddItemOk;

PROCEDURE AddItem* (MenuStrip: i.MenuPtr;
                    Name: ARRAY OF CHAR;
                    Flags: SET;
                    Excl: LONGSET;
                    Cmd: CHAR);
  (* $CopyArrays- *)
  BEGIN
    rq.Assert (AddItemOk (MenuStrip, Name, Flags, Excl, Cmd),
               OutOfMem);
  END AddItem;

PROCEDURE AddSubItemOk* (MenuStrip: i.MenuPtr;
                         Name: ARRAY OF CHAR;
                         Flags: SET;
                         Excl: LONGSET;
                         Cmd: CHAR): BOOLEAN;
  (* $CopyArrays- *)
  VAR
    LastMenu: i.MenuPtr;
    LastItem: i.MenuItemPtr;
  BEGIN
    LastMenu:= FindLast (MenuStrip);
    LastItem:= FindLast (LastMenu.firstItem);
    RETURN InitItem (LastItem.subItem, Name, LastItem.width - 8, Flags,
                     Excl, Cmd)
  END AddSubItemOk;

PROCEDURE AddSubItem* (MenuStrip: i.MenuPtr;
                       Name: ARRAY OF CHAR;
                       LeftEdge: INTEGER;
                       Flags: SET;
                       Excl: LONGSET;
                       Cmd: CHAR);
  (* $CopyArrays- *)
  BEGIN
    rq.Assert (AddSubItemOk (MenuStrip, Name, Flags, Excl, Cmd), OutOfMem);
  END AddSubItem;

PROCEDURE DiscardMenu* (VAR MenuStrip: i.MenuPtr);
  VAR
    TextPtr: i.IntuiTextPtr;

  PROCEDURE FreeItems (Item: i.MenuItemPtr);
    BEGIN
      IF Item # NIL THEN
        FreeItems (Item.nextItem);
        FreeItems (Item.subItem);
        TextPtr:= Item.itemFill;
        DISPOSE (TextPtr.iText);
        DISPOSE (TextPtr);
        DISPOSE (Item);
      END;
    END FreeItems;

  BEGIN
    IF MenuStrip # NIL THEN
      DiscardMenu (MenuStrip.nextMenu);
      FreeItems (MenuStrip.firstItem);
      DISPOSE (MenuStrip.menuName);
      DISPOSE (MenuStrip);
      MenuStrip:= NIL;
    END;
  END DiscardMenu;

BEGIN
  CommWidth := 48;
  CheckWidth:= 24;
  StdHeight := 10;
  OutOfMem  := "Out of memory";
END Menus.