Subversion Repositories Kolibri OS

(*

    Copyright 2021 Anton Krotov

    This file is part of CEdit.

    CEdit is free software: you can redistribute it and/or modify

    it under the terms of the GNU General Public License as published by

    the Free Software Foundation, either version 3 of the License, or

    (at your option) any later version.

    CEdit is distributed in the hope that it will be useful,

    but WITHOUT ANY WARRANTY; without even the implied warranty of

    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License

    along with CEdit. If not, see .

*)

MODULE Menu;

IMPORT

    SYSTEM, G := Graph, List, K := KolibriOS;

CONST

    fontHeight = 22;

    fontWidth = 8;

    RIGHT = 16;

    LEFT = 16;

    TOP = 1;

    maxLEVEL = 1;

    backColor = 0F0F0F0H;

    foreColor = 0;

    selBackColor = 091C9F7H;

    selForeColor = 0;

    disBackColor = backColor;

    disForeColor = 808080H;

    disSelBackColor = 0E4E4E4H;

    disSelForeColor = disForeColor;

TYPE

    tMenu* = POINTER TO RECORD

        tid*: INTEGER;

        active*: BOOLEAN;

        parent*, child: tMenu;

        winX, winY, width*, height*: INTEGER;

        selItem, cliItem: INTEGER;

        font: G.tFont;

        canvas: G.tCanvas;

        items: List.tList;

        click: PROCEDURE (menu: tMenu; id: INTEGER);

        key: PROCEDURE (menu: tMenu; key: INTEGER): BOOLEAN

    END;

    tItem* = POINTER TO RECORD (List.tItem)

        id*, check: INTEGER;

        text: ARRAY 32 OF WCHAR;

        enabled, delim: BOOLEAN;

        child: tMenu

    END;

    tClick = PROCEDURE (menu: tMenu; id: INTEGER);

    tKey = PROCEDURE (menu: tMenu; key: INTEGER): BOOLEAN;

    tProc = PROCEDURE;

VAR

    stack: ARRAY maxLEVEL + 1, 250000 OF INTEGER;

    TIDs: ARRAY maxLEVEL + 1 OF INTEGER;

    resetTimer: tProc;

    _open: PROCEDURE (m: tMenu; x, y: INTEGER);

    redraw*: BOOLEAN;

(*

    backColor, foreColor, selBackColor, selForeColor,

    disBackColor, disForeColor, disSelBackColor, disSelForeColor: INTEGER;

*)

PROCEDURE isSender* (tid: INTEGER): BOOLEAN;

VAR

	i: INTEGER;

BEGIN

	i := 0;

	WHILE (i <= maxLEVEL) & (TIDs[i] # tid) DO

		INC(i)

	END

	RETURN i <= maxLEVEL

END isSender;

PROCEDURE exit (m: tMenu);

BEGIN

    m.tid := 0;

    m.active := FALSE;

    resetTimer;

    K.Exit

END exit;

PROCEDURE repaint (m: tMenu);

VAR

    y, i, X, Y1, Y2: INTEGER;

    item: tItem;

    BkColor, TextColor: INTEGER;

    canvas: G.tCanvas;

BEGIN

(*

    backColor := K.winColor;

    foreColor := K.textColor;

    selBackColor := K.btnColor;

    selForeColor := K.btnTextColor;

    disBackColor := backColor;

    disForeColor := K.darkColor;

    disSelBackColor := K.lightColor;

    disSelForeColor := disForeColor;

*)

    canvas := m.canvas;

    G.SetColor(canvas, backColor);

    G.clear(canvas);

    G.SetColor(canvas, ORD((-BITS(backColor))*{0..23}) );

    G.Rect(canvas, 0, 0, m.width, m.height);

    y := TOP;

    i := 0;

    item := m.items.first(tItem);

    WHILE item # NIL DO

        IF item.enabled THEN

            IF i # m.selItem THEN

                BkColor := backColor;

                TextColor := foreColor

            ELSE

                BkColor := selBackColor;

                TextColor := selForeColor

            END

        ELSE

            IF i # m.selItem THEN

                BkColor := disBackColor;

                TextColor := disForeColor

            ELSE

                BkColor := disSelBackColor;

                TextColor := disSelForeColor

            END

        END;

        G.SetColor(canvas, BkColor);

        G.FillRect(canvas, 1, y, m.width - 1, y + fontHeight - 4);

        G.SetTextColor(canvas, TextColor);

        G.SetBkColor(canvas, BkColor);

        G.TextOut2(canvas, LEFT, y + (fontHeight - 16) DIV 2 - 2, item.text, LENGTH(item.text));

        G.SetColor(canvas, TextColor);

        IF item.check = 1 THEN

            G.DLine(canvas, 4, 7, y + (fontHeight - 16) DIV 2 + 5, -1);

            G.DLine(canvas, 4, 7, y + (fontHeight - 16) DIV 2 + 6, -1);

            G.DLine(canvas, 7, 12, y + (fontHeight - 16) DIV 2 + 8, 1);

            G.DLine(canvas, 7, 12, y + (fontHeight - 16) DIV 2 + 9, 1);

        ELSIF item.check = 2 THEN

            G.FillRect(canvas, 6, y + fontHeight DIV 2 - 4, 10, y + fontHeight DIV 2)

        END;

        IF item.child # NIL THEN

            X := m.width - 9;

            Y1 := y + (fontHeight - 16) DIV 2 + 2;

            Y2 := Y1 + 8;

        	G.Triangle(canvas, X, Y1, X, Y2, G.triRight)

        END;

        INC(y, fontHeight);

        IF item.delim THEN

            G.SetColor(canvas, ORD((-BITS(backColor))*{0..23}));

            G.HLine(canvas, y - 2, 1, m.width - 1)

        END;

        INC(i);

        item := item.next(tItem)

    END;

    G.DrawCanvas(canvas, 0, 0)

END repaint;

PROCEDURE draw_window (m: tMenu);

BEGIN

    K.BeginDraw;

    K.CreateWindow(m.winX, m.winY, m.width, m.height, 0, 61H, 0, 1, "");

    repaint(m);

    K.EndDraw

END draw_window;

PROCEDURE mouse (m: tMenu; VAR x, y: INTEGER);

VAR

    mouseX, mouseY: INTEGER;

BEGIN

    K.MousePos(mouseX, mouseY);

    x := mouseX - m.winX;

    y := mouseY - m.winY;

END mouse;

PROCEDURE close* (m: tMenu);

BEGIN

    IF (m # NIL) & (m.tid # 0) THEN

    	IF m.child # NIL THEN

    		close(m.child);

    		m.child := NIL

    	END;

        K.ExitID(m.tid);

        m.tid := 0;

        m.active := FALSE

    END

END close;

PROCEDURE click (m: tMenu; i: INTEGER);

VAR

    item: List.tItem;

    p: tMenu;

BEGIN

    item := List.getItem(m.items, i);

    IF (item # NIL) & item(tItem).enabled & (item(tItem).child = NIL) THEN

        m.click(m, item(tItem).id);

        p := m.parent;

       	WHILE p # NIL DO

       		p.child := NIL;

       		close(p);

       		p := p.parent

       	END;

       	redraw := TRUE;

       	exit(m)

    END

END click;

PROCEDURE opened* (m: tMenu): BOOLEAN;

    RETURN m.tid # 0

END opened;

PROCEDURE isActive (m: tMenu): BOOLEAN;

	RETURN (m # NIL) & ((m.tid # 0) & m.active OR isActive(m.child))

END isActive;

PROCEDURE closeChild (m: tMenu);

BEGIN

	IF m.child # NIL THEN

		redraw := FALSE;

		close(m.child);

		m.child := NIL

	END

END closeChild;

PROCEDURE submenu (m: tMenu);

VAR

	item: List.tItem;

BEGIN

    item := List.getItem(m.items, m.selItem);

    IF (item # NIL) & item(tItem).enabled & (item(tItem).child # NIL) THEN

    	IF ~opened(item(tItem).child) THEN

    		closeChild(m);

    		_open(item(tItem).child, m.winX + m.width - 2, m.winY + m.selItem*fontHeight);

    		m.child := item(tItem).child

    	END

    ELSE

    	closeChild(m)

    END

END submenu;

PROCEDURE [stdcall] window (m: tMenu);

VAR

    x, y: INTEGER;

    key: INTEGER;

    msState: SET;

BEGIN

    m.selItem := -1;

    m.cliItem := -1;

    K.SetEventsMask({0, 1, 5});

    WHILE TRUE DO

        CASE K.WaitForEvent() OF

        |1:

            draw_window(m)

        |2:

            key := K.GetKey();

            IF key DIV 65536 = 72 THEN

                DEC(m.selItem);

                IF m.selItem < 0 THEN

                    m.selItem := 0

                END

            ELSIF key DIV 65536 = 80 THEN

                INC(m.selItem);

                IF m.selItem >= m.items.count THEN

                    m.selItem := m.items.count - 1

                END

            ELSIF key DIV 65536 = 28 THEN

                IF m.selItem >= 0 THEN

                    click(m, m.selItem)

                END;

                m.cliItem := -1

            ELSIF key DIV 65536 = 77 THEN

                submenu(m)

            ELSIF key DIV 65536 = 75 THEN

            	IF m.parent # NIL THEN

                	exit(m)

                END

            ELSE

                IF m.key(m, key) THEN

                    exit(m)

                END

            END;

            repaint(m)

        |6:

            msState := K.MouseState();

            mouse(m, x, y);

            IF (0 <= x) & (x < m.width) & (0 <= y) & (y < m.height) THEN

            	m.active := TRUE;

                m.selItem := (y - TOP) DIV fontHeight;

                IF 8 IN msState THEN

                    m.cliItem := (y - TOP) DIV fontHeight

                END;

                IF 16 IN msState THEN

                    IF m.cliItem = m.selItem THEN

                        click(m, m.cliItem)

                    END;

                    m.cliItem := -1

                END

            ELSE

            	m.active := FALSE;

                m.cliItem := -1;

                IF ({8, 9, 10, 16} * msState # {}) & ~isActive(m.child) THEN

                    exit(m)

                END

            END;

            repaint(m);

            submenu(m)

        END

    END

END window;

PROCEDURE level (m: tMenu): INTEGER;

VAR

	res: INTEGER;

BEGIN

	res := 0;

	WHILE m.parent # NIL DO

		INC(res);

		m := m.parent

	END

	RETURN res

END level;

PROCEDURE open* (m: tMenu; x, y: INTEGER);

VAR

	L: INTEGER;

BEGIN

    IF m.tid = 0 THEN

        m.winX := x;

        m.winY := y;

        L := level(m);

        SYSTEM.PUT(SYSTEM.ADR(stack[L][LEN(stack[0]) - 1]), m);

        m.tid := K.CreateThread(SYSTEM.ADR(window), stack[L]);

        TIDs[L] := m.tid

    END

END open;

PROCEDURE AddMenuItem* (items: List.tList; id: INTEGER; s: ARRAY OF WCHAR);

VAR

    item: tItem;

BEGIN

    NEW(item);

    item.id := id;

    item.text := s;

    item.enabled := TRUE;

    item.delim := FALSE;

    item.child := NIL;

    List.append(items, item);

END AddMenuItem;

PROCEDURE delimiter* (items: List.tList);

BEGIN

    items.last(tItem).delim := TRUE

END delimiter;

PROCEDURE child* (items: List.tList; menu: tMenu);

BEGIN

    items.last(tItem).child := menu

END child;

PROCEDURE getItem (m: tMenu; id: INTEGER): tItem;

VAR

    item: tItem;

BEGIN

    item := m.items.first(tItem);

    WHILE (item # NIL) & (item.id # id) DO

        item := item.next(tItem)

    END

    RETURN item

END getItem;

PROCEDURE setEnabled* (m: tMenu; id: INTEGER; value: BOOLEAN);

VAR

    item: tItem;

BEGIN

    item := getItem(m, id);

    IF item # NIL THEN

        item.enabled := value

    END

END setEnabled;

PROCEDURE setCheck* (m: tMenu; id: INTEGER; value: INTEGER);

VAR

    item: tItem;

BEGIN

    item := getItem(m, id);

    IF item # NIL THEN

        item.check := value

    END

END setCheck;

PROCEDURE isEnabled* (m: tMenu; id: INTEGER): BOOLEAN;

VAR

    item: tItem;

BEGIN

    item := getItem(m, id)

    RETURN (item # NIL) & item.enabled

END isEnabled;

PROCEDURE create* (items: List.tList; click: tClick; key: tKey): tMenu;

VAR

    m: tMenu;

    maxLength: INTEGER;

    item: tItem;

BEGIN

    NEW(m);

    m.tid := 0;

    m.active := FALSE;

    m.parent := NIL;

    m.child := NIL;

    m.items  := items;

    m.click := click;

    m.key := key;

    maxLength := 0;

    item := items.first(tItem);

    WHILE item # NIL DO

        maxLength := MAX(maxLength, LENGTH(item.text));

        item := item.next(tItem)

    END;

    m.width  := maxLength*fontWidth + LEFT + RIGHT;

    m.height := items.count*fontHeight - 2;

    m.font := G.CreateFont(1, "", {});

    m.canvas := G.CreateCanvas(m.width + 1, m.height + 1);

    G.SetFont(m.canvas, m.font);

    RETURN m

END create;

PROCEDURE Redraw*;

BEGIN

	redraw := TRUE

END Redraw;

PROCEDURE init* (_resetTimer: tProc);

VAR

	i: INTEGER;

BEGIN

	Redraw;

	resetTimer := _resetTimer;

	_open := open;

	FOR i := 0 TO maxLEVEL DO

		TIDs[i] := 0

	END

END init;

END Menu.