Syntax10.Scn.Fnt
Syntax10i.Scn.Fnt
StampElems
Alloc
28 Apr 96
Syntax10b.Scn.Fnt
FoldElems
MODULE LocElems;	(** SHML, 4 Jan 96, 
, based on PopupElems **)
	(** Provide menu to locate positions in a text. As default, it searches for procedure headings.
		Other search procedures for specific file extensions can be installed. *)
	IMPORT
		Oberon, Input, Display, Viewers, Files, Fonts, Printer,
		Texts, TextFrames, MenuViewers, TextPrinter, Pictures, Amiga;
	CONST
		Ceres = FALSE;
		VersionTag = 0X;
		MenuDW = 3; MenuDH = 1;	(* margins of menu box *)
		DUnit = TextFrames.Unit; PUnit = TextPrinter.Unit;
		MR = 0; MM = 1; ML = 2; cancel = {ML, MM, MR};
		white = Display.white; black = Display.black;
		paint = Display.paint; replace = Display.replace; invert = Display.invert;
		StrLen*= 64;
		TableLen = 128;
	TYPE
		String = ARRAY StrLen OF CHAR;
		Entry = RECORD
			str: String;
			pos: LONGINT
		END;
		Table = ARRAY TableLen OF Entry;
		Elem*= POINTER TO ElemDesc;
		ElemDesc = RECORD (Texts.ElemDesc)
			name: ARRAY 32 OF CHAR;
			n, width: INTEGER;	(* number of items, width *)
			line: BOOLEAN;
			stampLen: LONGINT;
			t: Table
		END;
		SearchProc*= PROCEDURE(e: Elem; t: Texts.Text; VAR sort(*out*): BOOLEAN);
		Element = POINTER TO ElementDesc;
		ElementDesc = RECORD
			ext: ARRAY 32 OF CHAR; search: SearchProc;
			next: Element
		END;
	VAR wr: Texts.Writer; buf: Texts.Buffer; root: Element; defaultSearch: SearchProc; saveArea:Pictures.Picture;
	PROCEDURE Str(s: ARRAY OF CHAR);	BEGIN Texts.WriteString(wr, s) END Str;
	PROCEDURE Ln;	BEGIN Texts.WriteLn(wr) END Ln;
	(* non_portable stuff *)	
	PROCEDURE Save(X, Y, W, H: INTEGER);	(* copy from screen X, Y, W, H into save area *)
	BEGIN
		Pictures.Create(saveArea,W,H,Amiga.OberonDepth);
		Pictures.CopyBlock(Display.screen,saveArea,X,Y,W,H,0,0,replace)
	END Save;
	PROCEDURE Restore(X, Y, W, H: INTEGER);	(* restore from save area to screen X, Y, W, H *)
	BEGIN
		Pictures.CopyBlock(saveArea,Display.screen,0,0,W,H,X,Y,replace)
	END Restore;
	(* auxiliary *)	
	PROCEDURE Min(x, y: INTEGER): INTEGER;	BEGIN IF x < y THEN RETURN x ELSE RETURN y END END Min;
	PROCEDURE Max(x, y: INTEGER): INTEGER;	BEGIN IF x > y THEN RETURN x ELSE RETURN y END END Max;
	PROCEDURE StrDispWidth(fnt: Fonts.Font; s: ARRAY OF CHAR): LONGINT;
		VAR pat: Display.Pattern; width, i, dx, x, y, w, h: INTEGER;
	BEGIN
		width := 0; i := 0;
		WHILE s[i] # 0X DO Display.GetChar(fnt.raster, s[i], dx, x, y, w, h, pat); INC(width, dx); INC(i) END;
		RETURN LONG(width)*DUnit
	END StrDispWidth;
	PROCEDURE DispStr(fnt: Fonts.Font; s: ARRAY OF CHAR; col, x0, y0: INTEGER);
		VAR pat: Display.Pattern; i, dx, x, y, w, h: INTEGER;
	BEGIN
		i := 0;
		WHILE s[i] # 0X DO
			Display.GetChar(fnt.raster, s[i], dx, x, y, w, h, pat);
			Display.CopyPattern(col, pat, x0+x, y0+y, paint);
			INC(i); INC(x0, dx)
		END
	END DispStr;
	(* change propagation *)	
	PROCEDURE PrepareDraw(e: Elem; fnt: Fonts.Font; VAR dy: INTEGER);
		VAR width, dh: INTEGER;
	BEGIN
		width := 0; dh := 0; dy := fnt.minY;
		IF dy > -2 THEN dy := -2 END;
		e.W := LONG(width)*DUnit+StrDispWidth(fnt, e.name)+DUnit; e.H := LONG(fnt.maxY-fnt.minY+dh)*DUnit
	END PrepareDraw;
	PROCEDURE Sort(e: Elem);
		(* sort the array with insertion sort (because it's stable!) *)
		VAR i, j: INTEGER; entry: Entry;
	BEGIN
		FOR j := 1 TO e.n-1 DO
			entry := e.t[j];
			i := j-1;
			WHILE (i >= 0) & (entry.str < e.t[i].str) DO e.t[i+1] := e.t[i]; DEC(i) END;
			e.t[i+1] := entry
		END
	END Sort;
	PROCEDURE Append*(e: Elem; str: ARRAY OF CHAR; pos: LONGINT): BOOLEAN;
		(** append str and pos to table in element e, return "table is full"; (LEN(str) <= StrLen, 100) *)
	BEGIN
		ASSERT(LEN(str) <= StrLen, 100);
		IF e.n < TableLen THEN COPY(str, e.t[e.n].str); e.t[e.n].pos := pos; INC(e.n) END;
		RETURN e.n = TableLen
	END Append;
	PROCEDURE DefaultSearch(e: Elem; t: Texts.Text; VAR sort(*out*): BOOLEAN);
		VAR s: Texts.Scanner; str, type: ARRAY 32 OF CHAR; class, i, j: INTEGER;
	BEGIN
		Texts.OpenScanner(s, t, 0);
		LOOP
			WHILE ~s.eot & ((s.class # Texts.Name) OR (s.s # "PROCEDURE")) DO Texts.Scan(s) END;
			IF s.eot THEN EXIT END;
			(* s.s = PROCEDURE *)
			type := "";
			Texts.Scan(s);
			IF ~((s.class = Texts.Char) & (s.c = "^")) THEN	(* ignore forward declarations *)
				IF s.class = Texts.Char THEN	(* ( *)
					IF s.c = "(" THEN
						REPEAT COPY(s.s, type); class := s.class; Texts.Scan(s)
						UNTIL s.eot OR (class = Texts.Name) & (s.class = Texts.Char) & (s.c = ")");
						IF s.eot THEN EXIT END
					END;
					Texts.Scan(s)
				END;
				IF s.class = Texts.Name THEN
					i := -1;
					IF type # "" THEN
						REPEAT INC(i); str[i] := type[i] UNTIL str[i] = 0X;
						str[i] := "."
					END;
					j := -1;
					REPEAT INC(j); INC(i); str[i] := s.s[j] UNTIL str[i] = 0X;
					IF Append(e, str, Texts.Pos(s)-1) THEN EXIT END
				END
			END
		END;
		sort := TRUE
	END DefaultSearch;
	PROCEDURE Extension(name: ARRAY OF CHAR; VAR ext: ARRAY OF CHAR);
		VAR i, j: INTEGER;
	BEGIN
		i := -1; REPEAT INC(i) UNTIL name[i] = 0X;
		REPEAT DEC(i) UNTIL (name[i] = ".") OR (i = 0);
		IF i = 0 THEN ext[0] := 0X
		ELSE
			j := -1; REPEAT INC(i); INC(j); ext[j] := name[i] UNTIL (name[i] = 0X) OR (name[i] = '"');
			ext[j] := 0X
		END
	END Extension;
	PROCEDURE Search(ext: ARRAY OF CHAR; VAR prev: Element): Element;
		VAR l: Element;
	BEGIN
		l := root; prev := NIL;
		WHILE (l # NIL) & (l.ext # ext) DO prev := l; l := l.next END;
		RETURN l
	END Search;
	PROCEDURE Refresh(e: Elem; t: Texts.Text; menuFrame: Display.Frame);	(* generate menu text from t *)
		VAR
			s: Texts.Scanner; ext: ARRAY 32 OF CHAR; this, prev: Element;
			i, j, width, n, dx, x, y, w, h: INTEGER; p: LONGINT; sort: BOOLEAN;
	BEGIN
		IF t # NIL THEN
			e.n := 0; e.stampLen := t.len; sort := FALSE;
			WITH menuFrame: TextFrames.Frame DO
				Texts.OpenScanner(s, menuFrame.text, 0); Texts.Scan(s);
				IF s.class IN {Texts.Name, Texts.String} THEN
					Extension(s.s, ext); this := Search(ext, prev);
					IF this # NIL THEN this.search(e, t, sort) ELSE defaultSearch(e, t, sort) END
				ELSE defaultSearch(e, t, sort)
				END
			ELSE defaultSearch(e, t, sort)
			END;
			IF e.n > 0 THEN
				IF sort THEN Sort(e) END
			ELSE e.t[0].str := "no items in text"; e.t[0].pos := -1; e.n := 1
			END;
			n := e.n;
			WHILE n*Fonts.Default.height + 2*MenuDH + 4 > Oberon.DisplayHeight(0) DO DEC(n) END;
			IF n < e.n THEN
				e.n := n;
				Str("too many procedures, not all will be shown!"); Ln;
				Texts.Append(Oberon.Log, wr.buf)
			END;
			e.width := 0;
			FOR i := 0 TO n-1 DO
				j := 0; width := 0;
				WHILE e.t[i].str[j] # 0X DO
					Display.GetChar(Fonts.Default.raster, e.t[i].str[j], dx, x, y, w, h, p); INC(width, dx);
					INC(j)
				END;
				e.width := Max(e.width, width)
			END
		ELSE e.n := 0
		END
	END Refresh;
	(* file input/output *)	
	PROCEDURE Load(VAR r: Files.Rider; e: Elem);
		VAR ch: CHAR;
	BEGIN
		Files.Read(r, ch);
		IF ch = VersionTag THEN Files.ReadString(r, e.name); Files.ReadBool(r, e.line) END
	END Load;
	PROCEDURE Store(VAR r: Files.Rider; e: Elem);
	BEGIN Files.Write(r, VersionTag); Files.WriteString(r, e.name); Files.WriteBool(r, e.line)
	END Store;
	(* graphics *)	
	PROCEDURE Box(col, bkgnd, X, Y, W, H: INTEGER);
	BEGIN
		Display.ReplConst(col, X+1, Y+1, W-2, 1, replace);
		Display.ReplConst(col, X+1, Y+H-2, W-2, 1, replace);
		Display.ReplConst(col, X+1, Y+2, 1, H-4, replace);
		Display.ReplConst(col, X+W-2, Y+2, 1, H-4, replace);
		Display.ReplConst(col, X+4, Y, W-4, 1, replace);
		Display.ReplConst(col, X+W-1, Y+1, 1, H-4, replace);
		Display.ReplConst(bkgnd, X+2, Y+2, W-4, H-4, replace)
	END Box;
	PROCEDURE DrawElem(e: Elem; f: Display.Frame; pos: LONGINT; fnt: Fonts.Font; col, X, Y: INTEGER);
		VAR beg: LONGINT; parc: TextFrames.Parc; bkgndCol: INTEGER;
	BEGIN
		IF f IS TextFrames.Frame THEN bkgndCol := f(TextFrames.Frame).col ELSE bkgndCol := black END;
		TextFrames.ParcBefore(Texts.ElemBase(e), pos, parc, beg);
		INC(Y, SHORT(parc.dsr DIV DUnit));
		IF bkgndCol = col THEN col := ABS(white-col) END;
		DispStr(fnt, e.name, col, X, Y);
		IF e.line THEN Display.ReplPatternC(f, white, Display.grey1, X, Y-2, SHORT(e.W DIV DUnit), 1, X, Y-1, invert) END
	END DrawElem;
	PROCEDURE PrintElem(e: Elem; fnt: Fonts.Font; X, Y: INTEGER);
	BEGIN
		Printer.String(X, Y, e.name, fnt.name);
		IF e.line THEN Printer.ReplConst(X, Y-2, SHORT((e.W-1) DIV PUnit), 1) END
	END PrintElem;
	PROCEDURE DrawMenu(e: Elem; X, Y, W, H: INTEGER);
		VAR X0, dx, x, y, w, h, i, j: INTEGER; p: LONGINT;
	BEGIN
		Box(white, black, X, Y, W, H);
		X0 := X+MenuDW+2; Y := Y+H-Fonts.Default.height-Fonts.Default.minY-MenuDH-2;
		FOR i := 0 TO e.n-1 DO
			j := 0; X := X0;
			WHILE e.t[i].str[j] # 0X DO
				Display.GetChar(Fonts.Default.raster, e.t[i].str[j], dx, x, y, w, h, p);
				Display.CopyPattern(Display.white, p, X+x, Y+y, paint); INC(X, dx);
				INC(j)
			END;
			DEC(Y, Fonts.Default.height)
		END
	END DrawMenu;
	(* actions *)	
	PROCEDURE Show(e: Elem; X, Y: INTEGER; VAR cmd: INTEGER; VAR keySum: SET);
		VAR
			eH, W, H, w, newY, mx, my, top, bot, left, right, newCmd: INTEGER;
			keys: SET;
		PROCEDURE Flip(cmd: INTEGER);
		BEGIN
			IF cmd >= 0 THEN
				Display.ReplConst(white, left, top-(cmd+1)*Fonts.Default.height, right-left, Fonts.Default.height, invert)
			END
		END Flip;
	BEGIN
		eH := SHORT(e.H DIV DUnit);
		Input.Mouse(keys, mx, my);
		W := e.width + 2*MenuDW + 4; H := e.n*Fonts.Default.height + 2*MenuDH + 4;
		IF (e.n = 0) OR (W > Oberon.DisplayWidth(X)) OR (H > Oberon.DisplayHeight(X)) THEN
			IF e.n > 0 THEN Str("LocElem too big!"); Ln; Texts.Append(Oberon.Log, wr.buf) END;
			REPEAT Input.Mouse(keys, mx, my); Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, mx, my)
			UNTIL keys = {};
			keySum := cancel; cmd := -1
		ELSE
			w := Oberon.DisplayWidth(X); left := Display.Left;
			IF Ceres & (X >= Display.Left+Display.Width) THEN	(* adjust if on secondary *)
				INC(w, Display.Width); left := Display.Left+Display.Width
			END;
			X := Min(w-W, Max(mx-W DIV 2, left));	(* X >= left & X+W <= w *)
			newY := my-((e.n-cmd)*Fonts.Default.height-Fonts.Default.height DIV 2);
			IF (newY >= Display.Bottom) & (newY+H <= Oberon.DisplayHeight(X)) THEN	(* popup at mouse pos *)
				Y := newY
			ELSE	(* drop down *)
				IF Y-H > Display.Bottom THEN Y := Y-H ELSE Y := Y+eH END;
				IF Y+H > Oberon.DisplayHeight(X) THEN Y := Display.Bottom END
			END;
			left := X+3; right := X+W-3; bot := Y+MenuDH+3; top := Y+H-MenuDH-2;
			Oberon.RemoveMarks(X, Y, W, H); Oberon.FadeCursor(Oberon.Mouse);
			Save(X, Y, W, H);	(* save background *)
			DrawMenu(e, X, Y, W, H);
			Flip(cmd); keySum := {};
			REPEAT
				Input.Mouse(keys, mx, my); keySum := keySum+keys;
				Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, mx, my);
				IF keySum = cancel THEN cmd := -1
				ELSIF (mx >= left) & (mx <= right) & (my >= bot) & (my <= top) THEN
					newCmd := (top-my) DIV Fonts.Default.height;
					IF newCmd # cmd THEN Flip(cmd); Flip(newCmd); cmd := newCmd END
				ELSE Flip(cmd); cmd := -1
				END
			UNTIL keys = {};
			Oberon.FadeCursor(Oberon.Mouse);
			Restore(X, Y, W, H)	(* restore background *)
		END
	END Show;
	PROCEDURE Popup(e: Elem; msg: TextFrames.TrackMsg);
		VAR
			v: Viewers.Viewer; tf: TextFrames.Frame;
			cmd: INTEGER; keys: SET;
			beg, end: LONGINT;
	BEGIN
		v := Viewers.This(msg.frame.X, msg.frame.Y);
		IF (v IS MenuViewers.Viewer) & (v.dsc = msg.frame) & (v.dsc.next IS TextFrames.Frame) THEN
			tf := v.dsc.next(TextFrames.Frame);
			IF tf.text.len # e.stampLen THEN Refresh(e, tf.text, msg.frame) END;
			keys := msg.keys; cmd := 0;
			Show(e, msg.X0, msg.Y0, cmd, keys);
			IF keys = {MM, MR} THEN Refresh(e, tf.text, msg.frame)
			ELSIF (keys # cancel) & (cmd > -1) & (e.t[cmd].pos >= 0) THEN
				beg := tf.org; end := TextFrames.Pos(tf, tf.X+tf.W, tf.Y);
				IF (e.t[cmd].pos < beg) OR (end <= e.t[cmd].pos) THEN TextFrames.Show(tf, e.t[cmd].pos) END;
				Oberon.PassFocus(v);
				TextFrames.SetCaret(tf, e.t[cmd].pos)
			END
		ELSE Str("LocElem not in menu viewer or content frame is not TextFrame"); Ln; Texts.Append(Oberon.Log, wr.buf)
		END
	END Popup;
	(* element *)	
	PROCEDURE Handle(e: Texts.Elem; VAR msg: Texts.ElemMsg);
		VAR copy: Elem;
	BEGIN
		WITH e: Elem DO
			IF msg IS TextFrames.DisplayMsg THEN
				WITH msg: TextFrames.DisplayMsg DO
					IF msg.prepare THEN PrepareDraw(e, msg.fnt, msg.Y0)
					ELSE DrawElem(e, msg.frame, msg.pos, msg.fnt, msg.col, msg.X0, msg.Y0)
					END
				END
			ELSIF msg IS TextPrinter.PrintMsg THEN
				WITH msg: TextPrinter.PrintMsg DO
					IF ~msg.prepare THEN PrintElem(e, msg.fnt, msg.X0, msg.Y0) END
				END
			ELSIF msg IS Texts.CopyMsg THEN
				WITH msg: Texts.CopyMsg DO
					NEW(copy); Texts.CopyElem(e, copy);
					copy.name := e.name; copy.line := e.line;
					msg.e := copy
				END
			ELSIF msg IS Texts.IdentifyMsg THEN
				WITH msg: Texts.IdentifyMsg DO
					msg.mod := "LocElems"; msg.proc := "Alloc"
				END
			ELSIF msg IS Texts.FileMsg THEN
				WITH msg: Texts.FileMsg DO
					IF msg.id = Texts.load THEN Load(msg.r, e)
					ELSIF msg.id = Texts.store THEN Store(msg.r, e)
					END
				END
			ELSIF msg IS TextFrames.TrackMsg THEN
				WITH msg: TextFrames.TrackMsg DO Popup(e, msg) END
			END
		END
	END Handle;
	PROCEDURE Alloc*;
		VAR e: Elem;
	BEGIN NEW(e); e.handle := Handle; Texts.new := e
	END Alloc;
	(** commands **)	
	PROCEDURE Insert*;
		VAR e: Elem; ins: TextFrames.InsertElemMsg; s: Texts.Scanner;
	BEGIN
		NEW(e); e.line := TRUE;
		Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
		IF ~(s.class IN {Texts.Name, Texts.String}) OR (s.s[0] = 0X) THEN e.name := "Loc" ELSE COPY(s.s, e.name) END;
		e.handle := Handle; ins.e := e; Viewers.Broadcast(ins)
 	END Insert;
	PROCEDURE Rename*;
		VAR e: Elem; text: Texts.Text; beg, end, time: LONGINT; r: Texts.Reader; s: Texts.Scanner;
	BEGIN
		Oberon.GetSelection(text, beg, end, time);
		IF time >= 0 THEN
			Texts.OpenReader(r, text, beg); Texts.ReadElem(r);
			IF (r.elem # NIL) & (r.elem IS Elem) THEN
				e := r.elem(Elem);
				Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
				IF s.class = Texts.Name THEN
					COPY(s.s, e.name); text.notify(text, Texts.replace, Texts.ElemPos(e), Texts.ElemPos(e)+1)
				END
			END
		END
 	END Rename;
 	PROCEDURE Toggle*;
 		VAR e: Elem; text: Texts.Text; beg, end, time: LONGINT; r: Texts.Reader;
	BEGIN
 		Oberon.GetSelection(text, beg, end, time);
		IF time >= 0 THEN
			Texts.OpenReader(r, text, beg); Texts.ReadElem(r);
			IF (r.elem # NIL) & (r.elem IS Elem) THEN
				e := r.elem(Elem); e.line := ~e.line; text.notify(text, Texts.replace, Texts.ElemPos(e), Texts.ElemPos(e)+1)
			END
		END
 	END Toggle;
	PROCEDURE Install*(ext: ARRAY OF CHAR; search: SearchProc);
		VAR new, this, prev: Element;
	BEGIN
		IF ext = "*" THEN defaultSearch := search
		ELSE
			NEW(new); COPY(ext, new.ext); new.search := search;
			this := Search(new.ext, prev);	(* check for duplicates *)
			IF this = NIL THEN new.next := root; root := new	(* new entry *)
			ELSIF this.search # new.search THEN	(* new entry for existing extension -> remove this *)
				IF this = root THEN new.next := root.next; root := new
				ELSE new.next := this.next; prev.next := new
				END
			END
		END
	END Install;
BEGIN NEW(buf); Texts.OpenBuf(buf); Texts.OpenWriter(wr); root := NIL; defaultSearch := DefaultSearch; NEW(saveArea)
END LocElems.