Tigr-m2/tvision-m2/tvg.mod

IMPLEMENTATION MODULE tvg;

(* Graphics backend: renders tv's cell buffer with tigr and feeds tigr input
   back as tv events.  See tvg.def. *)

FROM SYSTEM IMPORT ADDRESS, ADR, CAST, BYTE;
FROM tigr IMPORT TigrPtr, tigrWindow, tigrFree, tigrUpdate, tigrClosed,
                 tigrFill, tigrBlitTint, tigrBitmap, tigrClear, tigrPlot,
                 tigrBlitMode, TPixelType, TIGR_BLEND_ALPHA,
                 tigrMouse, tigrKeyDown, tigrReadChar,
                 TIGR_FIXED,
                 TK_ESCAPE, TK_RETURN, TK_TAB, TK_BACKSPACE, TK_SPACE,
                 TK_LEFT, TK_RIGHT, TK_UP, TK_DOWN, TK_HOME, TK_END,
                 TK_PAGEUP, TK_PAGEDN, TK_INSERT, TK_DELETE,
                 TK_F1, TK_F2, TK_F3, TK_F4, TK_F5, TK_F6,
                 TK_F7, TK_F8, TK_F9, TK_F10, TK_F11, TK_F12;
IMPORT tv;
IMPORT tvfont;


VAR
    bmp        : TigrPtr;
    fontBmp    : TigrPtr;
    cw, ch     : INTEGER;
    qe         : ARRAY [0..63] OF tv.Event;
    qh, qn     : INTEGER;
    prevLeft   : BOOLEAN;
    prevRight  : BOOLEAN;
    prevMiddle : BOOLEAN;
    prevX, prevY : INTEGER;
    closedFlag : BOOLEAN;

(*========================================================================*)
(*  Colours                                                                *)
(*========================================================================*)

PROCEDURE Pal (i : INTEGER) : TPixelType;
    VAR p : TPixelType; r, g, b : INTEGER;
BEGIN
    CASE i OF
        0  : r:=0;   g:=0;   b:=0;
      | 1  : r:=0;   g:=0;   b:=170;
      | 2  : r:=0;   g:=170; b:=0;
      | 3  : r:=0;   g:=170; b:=170;
      | 4  : r:=170; g:=0;   b:=0;
      | 5  : r:=170; g:=0;   b:=170;
      | 6  : r:=170; g:=85;  b:=0;
      | 7  : r:=170; g:=170; b:=170;
      | 8  : r:=85;  g:=85;  b:=85;
      | 9  : r:=85;  g:=85;  b:=255;
      | 10 : r:=85;  g:=255; b:=85;
      | 11 : r:=85;  g:=255; b:=255;
      | 12 : r:=255; g:=85;  b:=85;
      | 13 : r:=255; g:=85;  b:=255;
      | 14 : r:=255; g:=255; b:=85;
    ELSE
        r:=255; g:=255; b:=255
    END;
    p.r := VAL(BYTE, r); p.g := VAL(BYTE, g);
    p.b := VAL(BYTE, b); p.a := VAL(BYTE, 255);
    RETURN p
END Pal;

PROCEDURE Fg (attr : CARDINAL) : TPixelType;
BEGIN RETURN Pal(VAL(INTEGER, attr MOD 16)) END Fg;

PROCEDURE Bg (attr : CARDINAL) : TPixelType;
BEGIN RETURN Pal(VAL(INTEGER, (attr DIV 16) MOD 16)) END Bg;

(*========================================================================*)
(*  Font / cells                                                           *)
(*========================================================================*)


PROCEDURE Bit (b : BYTE; k : INTEGER) : BOOLEAN;
    VAR m, i : INTEGER;
BEGIN
    m := 1;
    FOR i := 1 TO k DO m := m * 2 END;
    RETURN (VAL(INTEGER, b) DIV m) MOD 2 = 1
END Bit;

PROCEDURE BuildFont;
    VAR g, r, c : INTEGER; white, clear : TPixelType;
BEGIN
    fontBmp := tigrBitmap(VAL(CARDINAL, tvfont.NG * tvfont.CW),
                          VAL(CARDINAL, tvfont.CH));
    clear.r := VAL(BYTE, 0); clear.g := VAL(BYTE, 0);
    clear.b := VAL(BYTE, 0); clear.a := VAL(BYTE, 0);
    tigrClear(fontBmp, clear);
    tigrBlitMode(fontBmp, TIGR_BLEND_ALPHA);
    white.r := VAL(BYTE, 255); white.g := VAL(BYTE, 255);
    white.b := VAL(BYTE, 255); white.a := VAL(BYTE, 255);
    FOR g := 0 TO tvfont.NG - 1 DO
        FOR r := 0 TO tvfont.CH - 1 DO
            FOR c := 0 TO tvfont.CW - 1 DO
                IF Bit(tvfont.Row(g, r), tvfont.CW - 1 - c) THEN
                    tigrPlot(fontBmp,
                             VAL(CARDINAL, g * tvfont.CW + c),
                             VAL(CARDINAL, r), white)
                END
            END
        END
    END
END BuildFont;



PROCEDURE Seg (px, py, pw, ph : INTEGER; p : TPixelType);
BEGIN
    IF (pw > 0) AND (ph > 0) THEN
        tigrFill(bmp, VAL(CARDINAL, px), VAL(CARDINAL, py),
                 VAL(CARDINAL, pw), VAL(CARDINAL, ph), p)
    END
END Seg;

PROCEDURE DrawBoxGlyph (cp : CARDINAL; px, py : INTEGER; p : TPixelType);
    VAR mx, my : INTEGER;
BEGIN
    mx := px + cw DIV 2;
    my := py + ch DIV 2;
    IF cp = 2500H THEN Seg(px, my, cw, 1, p)                      (* ─ *)
    ELSIF cp = 2502H THEN Seg(mx, py, 1, ch, p)                   (* │ *)
    ELSIF cp = 250CH THEN                                          (* ┌ *)
        Seg(mx, my, cw - cw DIV 2, 1, p); Seg(mx, my, 1, ch - ch DIV 2, p)
    ELSIF cp = 2510H THEN                                          (* ┐ *)
        Seg(px, my, cw DIV 2 + 1, 1, p); Seg(mx, my, 1, ch - ch DIV 2, p)
    ELSIF cp = 2514H THEN                                          (* └ *)
        Seg(mx, my, cw - cw DIV 2, 1, p); Seg(mx, py, 1, ch DIV 2 + 1, p)
    ELSIF cp = 2518H THEN                                          (* ┘ *)
        Seg(px, my, cw DIV 2 + 1, 1, p); Seg(mx, py, 1, ch DIV 2 + 1, p)
    ELSIF cp = 2550H THEN                                          (* ═ *)
        Seg(px, my - 2, cw, 1, p); Seg(px, my + 1, cw, 1, p)
    ELSIF cp = 2551H THEN                                          (* ║ *)
        Seg(mx - 2, py, 1, ch, p); Seg(mx + 1, py, 1, ch, p)
    ELSIF cp = 2554H THEN                                          (* ╔ *)
        Seg(mx, my - 2, cw - cw DIV 2, 1, p); Seg(mx, my + 1, cw - cw DIV 2, 1, p);
        Seg(mx - 1, my, 1, ch - ch DIV 2, p); Seg(mx + 2, my, 1, ch - ch DIV 2, p)
    ELSIF cp = 2557H THEN                                          (* ╗ *)
        Seg(px, my - 2, cw DIV 2 + 1, 1, p); Seg(px, my + 1, cw DIV 2 + 1, 1, p);
        Seg(mx - 1, my, 1, ch - ch DIV 2, p); Seg(mx + 2, my, 1, ch - ch DIV 2, p)
    ELSIF cp = 255AH THEN                                          (* ╚ *)
        Seg(mx, my - 2, cw - cw DIV 2, 1, p); Seg(mx, my + 1, cw - cw DIV 2, 1, p);
        Seg(mx - 1, py, 1, ch DIV 2 + 1, p); Seg(mx + 2, py, 1, ch DIV 2 + 1, p)
    ELSIF cp = 255DH THEN                                          (* ╝ *)
        Seg(px, my - 2, cw DIV 2 + 1, 1, p); Seg(px, my + 1, cw DIV 2 + 1, 1, p);
        Seg(mx - 1, py, 1, ch DIV 2 + 1, p); Seg(mx + 2, py, 1, ch DIV 2 + 1, p)
    END
END DrawBoxGlyph;

PROCEDURE DrawCell (x, y : INTEGER; cp, attr : CARDINAL);
    VAR px, py, g : INTEGER; p : TPixelType;
BEGIN
    px := x * cw; py := y * ch;
    Seg(px, py, cw, ch, Bg(attr));
    IF cp >= 20H THEN
        p := Fg(attr);
        IF (cp >= 2500H) AND (cp <= 257FH) THEN
            DrawBoxGlyph(cp, px, py, p)
        ELSE
            g := tvfont.Index(cp);
            IF g < 0 THEN g := tvfont.Index(VAL(CARDINAL, ORD('?'))) END;
            IF g >= 0 THEN
                tigrBlitTint(bmp, fontBmp,
                             VAL(CARDINAL, px), VAL(CARDINAL, py),
                             VAL(CARDINAL, g * tvfont.CW), 0,
                             VAL(CARDINAL, tvfont.CW), VAL(CARDINAL, tvfont.CH), p)
            END
        END
    END
END DrawCell;

PROCEDURE BlitAll;
    VAR x, y : INTEGER; cp, attr : CARDINAL;
BEGIN
    FOR y := 0 TO tv.Rows() - 1 DO
        FOR x := 0 TO tv.Cols() - 1 DO
            tv.CellAt(x, y, cp, attr);
            DrawCell(x, y, cp, attr)
        END
    END
END BlitAll;

(*========================================================================*)
(*  Event queue                                                            *)
(*========================================================================*)

PROCEDURE Enq (e : tv.Event);
BEGIN
    IF qn < 64 THEN
        qe[(qh + qn) MOD 64] := e;
        qn := qn + 1
    END
END Enq;

PROCEDURE EnqKey (k : INTEGER);
    VAR e : tv.Event;
BEGIN
    e.kind := tv.evKey; e.key := k; e.ch := 0; e.ctrl := FALSE;
    e.mx := 0; e.my := 0; e.mbtn := 0;
    e.mpressed := FALSE; e.mreleased := FALSE; e.mwheel := 0;
    Enq(e)
END EnqKey;

PROCEDURE EnqChar (cp : CARDINAL);
    VAR e : tv.Event;
BEGIN
    e.kind := tv.evKey; e.key := tv.kChar; e.ch := cp; e.ctrl := FALSE;
    e.mx := 0; e.my := 0; e.mbtn := 0;
    e.mpressed := FALSE; e.mreleased := FALSE; e.mwheel := 0;
    Enq(e)
END EnqChar;

PROCEDURE EnqMouse (mx, my, btn : INTEGER; pressed, released : BOOLEAN;
                    wheel : INTEGER);
    VAR e : tv.Event;
BEGIN
    e.kind := tv.evMouse; e.key := tv.kNone; e.ch := 0; e.ctrl := FALSE;
    e.mx := mx DIV cw; e.my := my DIV ch; e.mbtn := btn;
    e.mpressed := pressed; e.mreleased := released; e.mwheel := wheel;
    Enq(e)
END EnqMouse;

(*========================================================================*)
(*  Input                                                                  *)
(*========================================================================*)

PROCEDURE Pump;
    VAR mx, my : CARDINAL; buttons : CARDINAL;
        left, right, middle : BOOLEAN; c : CARDINAL;
        ix, iy, held : INTEGER;
BEGIN
    tigrUpdate(bmp);
    IF tigrClosed(bmp) # 0 THEN
        IF NOT closedFlag THEN closedFlag := TRUE; EnqKey(tv.kEsc) END
    END;

    IF tigrKeyDown(bmp, TK_ESCAPE) # 0 THEN EnqKey(tv.kEsc) END;
    IF tigrKeyDown(bmp, TK_RETURN) # 0 THEN EnqKey(tv.kEnter) END;
    IF tigrKeyDown(bmp, TK_TAB) # 0 THEN EnqKey(tv.kTab) END;
    IF tigrKeyDown(bmp, TK_BACKSPACE) # 0 THEN EnqKey(tv.kBack) END;
    IF tigrKeyDown(bmp, TK_SPACE) # 0 THEN EnqKey(tv.kSpace) END;
    IF tigrKeyDown(bmp, TK_LEFT) # 0 THEN EnqKey(tv.kLeft) END;
    IF tigrKeyDown(bmp, TK_RIGHT) # 0 THEN EnqKey(tv.kRight) END;
    IF tigrKeyDown(bmp, TK_UP) # 0 THEN EnqKey(tv.kUp) END;
    IF tigrKeyDown(bmp, TK_DOWN) # 0 THEN EnqKey(tv.kDown) END;
    IF tigrKeyDown(bmp, TK_HOME) # 0 THEN EnqKey(tv.kHome) END;
    IF tigrKeyDown(bmp, TK_END) # 0 THEN EnqKey(tv.kEnd) END;
    IF tigrKeyDown(bmp, TK_PAGEUP) # 0 THEN EnqKey(tv.kPgUp) END;
    IF tigrKeyDown(bmp, TK_PAGEDN) # 0 THEN EnqKey(tv.kPgDn) END;
    IF tigrKeyDown(bmp, TK_INSERT) # 0 THEN EnqKey(tv.kIns) END;
    IF tigrKeyDown(bmp, TK_DELETE) # 0 THEN EnqKey(tv.kDel) END;
    IF tigrKeyDown(bmp, TK_F1) # 0 THEN EnqKey(tv.kF1) END;
    IF tigrKeyDown(bmp, TK_F2) # 0 THEN EnqKey(tv.kF2) END;
    IF tigrKeyDown(bmp, TK_F3) # 0 THEN EnqKey(tv.kF3) END;
    IF tigrKeyDown(bmp, TK_F4) # 0 THEN EnqKey(tv.kF4) END;
    IF tigrKeyDown(bmp, TK_F5) # 0 THEN EnqKey(tv.kF5) END;
    IF tigrKeyDown(bmp, TK_F6) # 0 THEN EnqKey(tv.kF6) END;
    IF tigrKeyDown(bmp, TK_F7) # 0 THEN EnqKey(tv.kF7) END;
    IF tigrKeyDown(bmp, TK_F8) # 0 THEN EnqKey(tv.kF8) END;
    IF tigrKeyDown(bmp, TK_F9) # 0 THEN EnqKey(tv.kF9) END;
    IF tigrKeyDown(bmp, TK_F10) # 0 THEN EnqKey(tv.kF10) END;
    IF tigrKeyDown(bmp, TK_F11) # 0 THEN EnqKey(tv.kF11) END;
    IF tigrKeyDown(bmp, TK_F12) # 0 THEN EnqKey(tv.kF12) END;

    LOOP
        c := tigrReadChar(bmp);
        IF c = 0 THEN EXIT END;
        IF c >= 20H THEN EnqChar(c) END
    END;

    tigrMouse(bmp, mx, my, buttons);
    ix := VAL(INTEGER, mx); iy := VAL(INTEGER, my);
    left   := (buttons MOD 2) = 1;
    right  := ((buttons DIV 2) MOD 2) = 1;
    middle := ((buttons DIV 4) MOD 2) = 1;

    IF left AND (NOT prevLeft) THEN EnqMouse(ix, iy, 1, TRUE, FALSE, 0) END;
    IF (NOT left) AND prevLeft THEN EnqMouse(ix, iy, 1, FALSE, TRUE, 0) END;
    IF right AND (NOT prevRight) THEN EnqMouse(ix, iy, 2, TRUE, FALSE, 0) END;
    IF (NOT right) AND prevRight THEN EnqMouse(ix, iy, 2, FALSE, TRUE, 0) END;
    IF middle AND (NOT prevMiddle) THEN EnqMouse(ix, iy, 3, TRUE, FALSE, 0) END;
    IF (NOT middle) AND prevMiddle THEN EnqMouse(ix, iy, 3, FALSE, TRUE, 0) END;

    held := 0;
    IF left THEN held := 1
    ELSIF right THEN held := 2
    ELSIF middle THEN held := 3 END;
    IF (ix # prevX) OR (iy # prevY) OR
       (left # prevLeft) OR (right # prevRight) OR (middle # prevMiddle) THEN
        EnqMouse(ix, iy, held, FALSE, FALSE, 0)
    END;
    prevX := ix; prevY := iy;
    prevLeft := left; prevRight := right; prevMiddle := middle
END Pump;

PROCEDURE ReadEvent (VAR e : Event) : BOOLEAN;
BEGIN
    IF qn = 0 THEN Pump END;
    IF qn = 0 THEN RETURN FALSE END;
    e := qe[qh];
    qh := (qh + 1) MOD 64;
    qn := qn - 1;
    RETURN TRUE
END ReadEvent;

(*========================================================================*)
(*  Lifecycle                                                              *)
(*========================================================================*)

PROCEDURE InitGfx (title : ARRAY OF CHAR; cols, rows : INTEGER) : BOOLEAN;
    VAR discard : INTEGER; ww, hh : INTEGER;
BEGIN
    cw := tvfont.CW; ch := tvfont.CH;
    BuildFont;
    IF cols < 10 THEN cols := 80 END;
    IF rows < 3 THEN rows := 30 END;
    ww := cols * cw; hh := rows * ch;
    bmp := tigrWindow(VAL(CARDINAL, ww), VAL(CARDINAL, hh), title, TIGR_FIXED);
    IF bmp = NIL THEN RETURN FALSE END;
    IF NOT tv.InitVirtual(cols, rows) THEN RETURN FALSE END;
    qh := 0; qn := 0;
    prevLeft := FALSE; prevRight := FALSE; prevMiddle := FALSE;
    prevX := -1; prevY := -1;
    closedFlag := FALSE;
    BlitAll;
    tigrUpdate(bmp);
    RETURN TRUE
END InitGfx;

PROCEDURE Finish;
BEGIN
    tv.DrawTree;
    BlitAll
END Finish;

PROCEDURE Closed () : BOOLEAN;
BEGIN RETURN closedFlag END Closed;

PROCEDURE CellW () : INTEGER;
BEGIN RETURN cw END CellW;

PROCEDURE CellH () : INTEGER;
BEGIN RETURN ch END CellH;

PROCEDURE Done;
BEGIN
    IF bmp # NIL THEN tigrFree(bmp); bmp := NIL END;
    IF fontBmp # NIL THEN tigrFree(fontBmp); fontBmp := NIL END
END Done;

END tvg.