MODULE Menu;


(*------  importlist:  ------*)


IMPORT sys := SYSTEM,
       g   := Graphics,
       str := Strings,
       I   := Intuition;


(*------  Globals:  ------*)


VAR
  oom*: PROCEDURE();              (* Wird bei Speichermangel aufgerufen, sollte entweder
                                     versuchen, Speicher freizugeben und zurückkehren, oder
                                     das Programm abbrechen. *)

  FirstMenu,LastMenu: I.MenuPtr;  (* Erster und letzter Menüstreifen *)
  LastItem: I.MenuItemPtr;        (* Zuletzt erzeugtes Item          *)

  leftBase: INTEGER;    (* linke Kante des Menütitels  *)
  height: INTEGER;      (* Höhe des Menüs              *)
  ItemWidth: INTEGER;   (* Breite des breitesten Itemtextes   *)
  ItemWidth2: INTEGER;  (* Breite des breitesten Itemtextes 2 *)
  rp: g.RastPortPtr;    (* RastPort des Screens        *)
  screen: I.ScreenPtr;  (* Der Screen selbst           *)
  commandWidth: INTEGER;(* Breite des Breitetsten Command-Keys *)


(*------  Menü Starten Menue:  ------*)


PROCEDURE StartMenu*(win: I.WindowPtr);
(* Diese Prozedur muß vor allen anderen Prozeduren dieses Moduls aufgerufen werden. *)

BEGIN
  leftBase := 0;
  FirstMenu := NIL;
  LastMenu := NIL;
  screen := win.wScreen;
  rp := sys.ADR(screen.rastPort);
END StartMenu;


(*------  EndStrip:  ------*)


PROCEDURE EndStrip;
(* Interne Prozedur, beendet aktuelle Menuleiste und setzt Breite der Items *)

VAR
  it: I.IntuiTextPtr;
  im: I.ImagePtr;
  top, left,height,width: INTEGER;

BEGIN
  INC(ItemWidth,g.TextLength(rp,"M",1));
  INC(commandWidth,I.commWidth);
  IF commandWidth>ItemWidth2 THEN ItemWidth2 := commandWidth END;
  LastItem := LastMenu.firstItem;
  left := 0; height := 0; width := ItemWidth + ItemWidth2 + 2;
  WHILE LastItem#NIL DO
    LastItem.width := width;
    height := LastItem.topEdge + LastItem.height;
    INC(LastItem.leftEdge,left);
    IF I.itemText IN LastItem.flags THEN
      it := LastItem.itemFill;
      it := it.nextText;
      IF it#NIL THEN
        it.leftEdge := LastItem.width-2;
        DEC(it.leftEdge,g.TextLength(rp,it.iText^,str.Length(it.iText^)));
      END;
    ELSE
      im := LastItem.itemFill;
      im.width := ItemWidth+ItemWidth2;
    END;
    LastItem := LastItem.nextItem;
  END;
  IF height + screen.barHeight + 4 > screen.height THEN
    LastItem := LastMenu.firstItem;
    WHILE (LastItem#NIL) AND (LastItem.topEdge + LastItem.height < height DIV 2) DO
      LastItem := LastItem.nextItem;
    END;
    IF LastItem#NIL THEN
      left := height - LastItem.topEdge + LastItem.height;
      IF left - (LastItem.topEdge + LastItem.height) >= LastItem.height THEN
        LastItem := LastItem.nextItem;
      END;
      IF LastItem#NIL THEN
        top := LastItem.topEdge;
        left := width + 4; INC(width,left);
        WHILE LastItem#NIL DO
          DEC(LastItem.topEdge,top);
          INC(LastItem.leftEdge,left);
          LastItem := LastItem.nextItem;
        END;
      END;
    END;
  END;
  IF width + LastMenu.leftEdge + 16 > screen.width THEN
    DEC(width,screen.width - LastMenu.leftEdge - 16);
    IF width > LastMenu.leftEdge THEN width := LastMenu.leftEdge END;
    LastItem := LastMenu.firstItem;
    WHILE (LastItem#NIL) DO
      DEC(LastItem.leftEdge,width);
      LastItem := LastItem.nextItem;
    END;
  END;
END EndStrip;


(*------  NewMenu:  ------*)


PROCEDURE NewMenu*(name: ARRAY OF CHAR); (* $CopyArrays- *)
(* Startet neue Menüleiste. Parameter ist der Name dieses Menüs.
 * NewMenu muß aufgerufen werden, bevor eine der Itemprozeduren
 * (s.u.) aufgerufen wird.
 *)

VAR
  m: I.MenuPtr;

BEGIN
  IF LastMenu#NIL THEN EndStrip END;
  LOOP
    NEW(m); IF m#NIL THEN EXIT END;
    oom;
  END;
  IF FirstMenu=NIL THEN FirstMenu         := m;
                   ELSE LastMenu.nextMenu := m END;
  LastMenu := m;
  m.leftEdge  := leftBase;
  m.topEdge   := 0;
  m.width     := g.TextLength(rp,name,str.Length(name))+12;
  INC(leftBase,m.width+10);
  m.height    := 0;
  m.flags     := {I.miDrawn,I.menuEnabled};
  m.menuName  := sys.ADR(name);
  m.firstItem := NIL;
  LastItem := NIL;
  ItemWidth := 0;
  ItemWidth2 := 0;
  height := 0;
  commandWidth := 0;
END NewMenu;


(*------  Item:  ------*)


PROCEDURE Item(name: ARRAY OF CHAR;
               name2: ARRAY OF CHAR;
               com: CHAR;
               checkmark,checked: BOOLEAN); (* $CopyArrays- *)
(* Interne Prozedur zum Erzeugen von Menuitems *)


VAR
  t: I.MenuItemPtr;
  it,it2: I.IntuiTextPtr;
  w: INTEGER;
  comstr: ARRAY 1 OF CHAR;

BEGIN
  LOOP
    NEW(t);
    IF t#NIL THEN EXIT END;
    oom;
  END;
  LOOP
    NEW(it);
    IF it#NIL THEN EXIT END;
    oom;
  END;
  IF LastItem=NIL THEN LastMenu.firstItem := t
                  ELSE LastItem.nextItem  := t END;
  LastItem := t;
  t.leftEdge  := 2;
  t.topEdge   := height;
  w := g.TextLength(rp,name,str.Length(name));
  IF checkmark THEN INC(w,I.checkWidth) END;
  IF w>ItemWidth THEN ItemWidth := w END;
  t.height    := rp.font.ySize+2;
  INC(height,t.height + t.height DIV 10);
  t.flags     := {I.itemText,I.itemEnabled,I.highComp};
  IF checkmark THEN
    t.flags := t.flags + {I.checkIt,I.menuToggle};
    IF checked THEN INCL(t.flags,I.checked) END;
  END;
  IF com#0X THEN
    INCL(t.flags,I.commSeq);
    comstr[0] := com;
    w := g.TextLength(rp,comstr,1);
    IF w>commandWidth THEN commandWidth := w END;
  END;
  t.mutualExclude := LONGSET{};
  t.itemFill  := it;
  t.selectFill:= NIL;
  t.command   := com; t.subItem  := NIL;
  it.frontPen := screen.detailPen; it.backPen := screen.blockPen;
  it.drawMode := g.jam2;
  it.iTextFont:= NIL;
  it.topEdge  := 1;
  it.leftEdge := 2;
  IF checkmark THEN INC(it.leftEdge,I.checkWidth) END;
  it.iText    := sys.ADR(name);
  IF name2[0]#0X THEN
    LOOP
      NEW(it2);
      IF it2#NIL THEN EXIT END;
      oom;
    END;
    it2^ := it^;
    it2.iText := sys.ADR(name2);
    it.nextText := it2;
    w := g.TextLength(rp,name2,str.Length(name2));
    IF w>ItemWidth2 THEN ItemWidth2 := w END;
  END;
END Item;


(*------  NewItem:  ------*)


PROCEDURE NewItem*(name: ARRAY OF CHAR;
                   com: CHAR);                  (* $CopyArrays- *)

(* erzeugt neues Menuitem mit Namen name und Tastatur-Shortcut Amiga+com.
 * Ist com=0X hat dieser Menüpunkt keine Tastaturabkürzung
 *)

BEGIN
  Item(name,"",com,FALSE,FALSE);
END NewItem;


(*------  NewItem2:  ------*)


PROCEDURE NewItem2*(name: ARRAY OF CHAR;
                    name2: ARRAY OF CHAR);      (* $CopyArrays- *)

(* erzeugt neues Menuitem mit Namen name und name2. name2 wird dabei
 * rechtsbündig ins Menü eingefügt. Es sollte vor allem für Tastatur-
 * abkürzungen wie '^Q' verwendet werden.
 *)

BEGIN
  Item(name,name2,0X,FALSE,FALSE);
END NewItem2;


(*------  NewItemChecked:  ------*)


PROCEDURE NewItemChecked*(name: ARRAY OF CHAR;
                          com: CHAR;
                          checked: BOOLEAN);    (* $CopyArrays- *)

(* erzeugt neues Menuitem mit Namen name und Tastatur-Shortcut Amiga+com.
 * Ist com=0X hat dieser Menüpunkt keine Tastaturabkürzung. Dieses Menü
 * bekommt ein Häkchen. Ist checked=TRUE, wird dieses Häkchen gleich
 * gesetzt.
 *)

BEGIN
  Item(name,"",com,TRUE,checked);
END NewItemChecked;


(*------  NewItemChecked:  ------*)


PROCEDURE NewItem2Checked*(name: ARRAY OF CHAR;
                           name2: ARRAY OF CHAR;
                           checked: BOOLEAN);    (* $CopyArrays- *)

(* erzeugt neues Menuitem mit Namen name und name2. name2 wird dabei
 * rechtsbündig ins Menü eingefügt. Es sollte vor allem für Tastatur-
 * abkürzungen wie '^Q' * verwendet werden. Dieses Menü bekommt ein
 * Häkchen. Ist checked=TRUE, wird dieses Häkchen gleich gesetzt.
 *)

BEGIN
  Item(name,name2,0X,TRUE,checked);
END NewItem2Checked;


(*------  Seperator:  ------*)


PROCEDURE Seperator*;
(* Erzeugt Linie *)


VAR
  t: I.MenuItemPtr;
  im: I.ImagePtr;
  comstr: ARRAY 1 OF CHAR;

BEGIN
  LOOP
    NEW(t);
    IF t#NIL THEN EXIT END;
    oom;
  END;
  LOOP
    NEW(im);
    IF im#NIL THEN EXIT END;
    oom;
  END;
  IF LastItem=NIL THEN LastMenu.firstItem := t
                  ELSE LastItem.nextItem  := t END;
  LastItem := t;
  t.leftEdge  := 2;
  t.topEdge   := height;
  t.height    := 5;
  INC(height,5);
  t.flags     := I.highNone;
  t.mutualExclude := LONGSET{};
  t.itemFill  := im;
  t.selectFill:= NIL;
  t.command   := 0X;
  t.subItem   := NIL;
  im.leftEdge := 1;
  im.topEdge  := 1;
  im.width    := 0;
  im.height   := 2;
  im.depth    := 0;
  im.imageData:= NIL;
  im.planePick:= SHORTSET{};
  im.planeOnOff:= SHORTSET{};
  im.nextImage:= NIL;
END Seperator;


(*------  EndMenu:  ------*)


PROCEDURE EndMenu*(): I.MenuPtr;

(* Beendet das Menü und gibt einen Zeiger auf die Menüstruktur zurück. Das Ergebnis
 * ist #NIL wenn NewMenu() mindestens einmal aufgerufen wurde.
 *)

BEGIN
  EndStrip;
  RETURN FirstMenu;
END EndMenu;




(*------  EndMenu:  ------*)


PROCEDURE DisposeMenu*(m: I.MenuPtr);

(* Gibt den Speicher des Menüs wieder frei: *)

  PROCEDURE DisposeText(t: I.IntuiTextPtr);
  BEGIN
    IF t#NIL THEN
      DisposeText(t.nextText);
      DISPOSE(t);
    END;
  END DisposeText;

  PROCEDURE DisposeImage(i: I.ImagePtr);
  BEGIN
    IF i#NIL THEN
      DisposeImage(i.nextImage);
      DISPOSE(i);
    END;
  END DisposeImage;

  PROCEDURE DisposeItem(i: I.MenuItemPtr);
  BEGIN
    IF i#NIL THEN
      DisposeItem(i.nextItem);
      IF I.itemText IN i.flags THEN DisposeText (i.itemFill)
                               ELSE DisposeImage(i.itemFill) END;
      DISPOSE(i);
    END;
  END DisposeItem;

BEGIN
  IF m#NIL THEN
    DisposeMenu(m.nextMenu);
    DisposeItem(m.firstItem);
    DISPOSE(m);
  END;
END DisposeMenu;


(*------  OOM:  ------*)


PROCEDURE * OOM;

(* Voreingestellte Prozedur für oom:
 *)

BEGIN
  HALT(20);
END OOM;


(*------  Initialisierung:  ------*)


BEGIN

  oom := OOM;

END Menu.