{ glio graphics library for turbo pascal with BGI interface }
{ (c) Kenrou Adachi, 2006/03/14                             }
{ graphics.pas                                              }


Unit graphics;

Interface

uses dos;

const
    NEC   = 1.0;  EPSON = 0.8888889;
    BLACk  = 0;   BLUE   = 1;   RED    = 2;   VIOLET = 3;
    GREEN  = 4;   CYAN   = 5;   YELLOW = 6;   WHITE  = 7;

procedure glio(fnctno : byte);
procedure graphdefaults;
procedure set0(x0, y0, k : integer);
procedure setyscale(scale : real);
procedure setcolor(drc : byte);
procedure setlinepattern(lptn : integer);
procedure setfillcolor(flc : byte);
procedure setfillpattern(size : integer; dat : word);
procedure ginit;
procedure gclose;
procedure setscreenmode(act, vis : byte);
procedure setactivepage(act : byte);
procedure setvisualpage(vis : byte);
procedure setcolourmode(bkc, frc : byte);
procedure setbkcolor(bkc : byte);
procedure setfrcolor(frc : byte);
procedure setpalette(pal, col : byte);
procedure cleardevice;
procedure putpixel(x, y : integer; drc : byte);
procedure line(x1, y1, x2, y2 : integer);
procedure rectangle(x1, y1, x2, y2 : integer);
procedure circle(x0, y0, r : integer);
procedure ellipse(x, y, rx, ry : integer);
procedure floodfill(x, y : integer; bdc : byte);
procedure getimage(x1, y1, x2, y2 : integer; buf : word);
procedure putimage(x, y : integer; buf : word; mode : byte);
procedure putkanji(x, y : integer; code : word; mode : byte);
procedure moveimage(x, y : integer);
function  getpixel(x, y : integer) : byte;
procedure cleartextscreen;
procedure fkeyoff;
procedure fkeyon;
procedure cursoroff;
procedure cursoron;
procedure setlp(tlpx, tlpy : real);
procedure setangle(ang : real);
procedure turn(ang : real);
procedure warp(leng : real);
procedure move(leng : real);


Implementation

type
    arguments = array[1..23] of byte;

const
    ESC = #$1b;

var
    workarea    : array[1..$1400] of byte;
    regs        : registers;
    segbase     : word;
    offset      : word;
    PARAM       : arguments absolute workarea;

    Y_FLAG, X_0, Y_0                       : integer;
    Y_SCALE                                : real;
    ACT_PAGE, VIS_PAGE, BK_COLOR, FR_COLOR : byte;
    LINE_SW, RECT_SW                       : word;
    CIRC_SW, PIE_SW, FILL_SW               : byte;
    DRAW_COLOR, FILLPTNSIZE                : byte;
    LINE_PTN, FILLPTNOFF, IMAGE_SIZE       : word;
    color_code                             : array[0..15] of word;
    LPX, LPY, ANGLE                        : real;
    CPX, CPY                               : integer;


procedure glio(fnctno : byte);
begin
    with regs do
    begin
        regs.bx := offset;
        regs.ds := segbase
    end;
    intr(fnctno, regs);
end;


procedure graphdefaults;
begin
    Y_FLAG   := 0;
    X_0      := 0;
    Y_0      := 0;
    Y_SCALE  := NEC;
    ACT_PAGE := 0;
    VIS_PAGE := 0;
    BK_COLOR := 0;
    FR_COLOR := 7;
    LINE_SW  := $0000;
    RECT_SW  := $0001;
    CIRC_SW  := $00;
    PIE_SW   := $0f;
    FILL_SW  := 0;
    DRAW_COLOR  := 7;
    LINE_PTN    := $ffff;
    FILLPTNSIZE := 0;
    FILLPTNOFF  := 0;
    IMAGE_SIZE  := 0;
    color_code[0] := $0000;
    color_code[1] := $000f;
    color_code[2] := $00f0;
    color_code[3] := $00ff;
    color_code[4] := $0f00;
    color_code[5] := $0f0f;
    color_code[6] := $0ff0;
    color_code[7] := $0fff;
    color_code[8] := $0777;
    color_code[9] := $000a;
    color_code[10] := $00a0;
    color_code[11] := $00aa;
    color_code[12] := $0a00;
    color_code[13] := $0a0a;
    color_code[14] := $0aa0;
    color_code[15] := $0aaa;
end;


procedure set0(x0, y0, k : integer);
begin
    X_0 := x0;
    Y_0 := y0;
    Y_FLAG := k
end;


procedure setyscale(scale : real);
begin
    Y_SCALE := scale
end;


procedure setcolor(drc : byte);
begin
    DRAW_COLOR := drc
end;


procedure setlinepattern(lptn : integer);
begin
    LINE_SW := $0100;
    RECT_SW := $0101;
    LINE_PTN := lptn
end;


procedure setfillcolor(flc : byte);
begin
    if (flc >= 0) and (flc <= 15) then
    begin
        RECT_SW := $0102;
        CIRC_SW := $20;
        PIE_SW  := $2f;
        LINE_PTN := flc;
        FILLPTNSIZE := flc
    end
    else
    begin
        RECT_SW := $0002;
        CIRC_SW := $20;
        PIE_SW  := $2f;
        LINE_PTN := $ffff;
        FILLPTNSIZE := $ff
    end;
    FILL_SW := 0;
end;


procedure setfillpattern(size : integer; dat : word);
begin
    RECT_SW := $0202;
    CIRC_SW := $60;
    PIE_SW  := $6f;
    FILL_SW := 1;
    FILLPTNSIZE := size;
    FILLPTNOFF  := dat
end;


procedure setscreenmode(act, vis : byte);
begin
    ACT_PAGE := act;
    VIS_PAGE := vis;
    PARAM[1] := 3;
    PARAM[2] := 0;
    PARAM[3] := ACT_PAGE;
    if VIS_PAGE = 0 then
        PARAM[4] := 1
    else
        PARAM[4] := 1; { 33 }
    glio($a1)
end;


procedure setactivepage(act : byte);
begin
    ACT_PAGE := act;
    setscreenmode(ACT_PAGE, $ff)
end;


procedure setvisualpage(vis : byte);
begin
    VIS_PAGE := vis;
    setscreenmode($ff, VIS_PAGE)
end;


procedure cleartextscreen;
begin
    write(ESC, '[2J')
end;


procedure fkeyoff;
begin
    write(ESC, '[>1h')
end;


procedure fkeyon;
begin
    write(ESC, '[>1l')
end;


procedure cursoroff;
begin
    write(ESC, '[>5h')
end;


procedure cursoron;
begin
    write(ESC, '[>5l')
end;


procedure cleardevice;
begin
    glio($a5);
    CPX := 0;
    CPY := 0
end;


procedure setcolourmode(bkc, frc : byte);
begin
    BK_COLOR := bkc;
    FR_COLOR := frc;
    PARAM[2] := BK_COLOR;
    PARAM[3] := 0;
    PARAM[4] := FR_COLOR;
    PARAM[5] := FR_COLOR;
    glio($a3);
    cleardevice;
end;


procedure setbkcolor(bkc : byte);
begin
    BK_COLOR := bkc;
    setcolourmode(BK_COLOR, $ff)
end;


procedure setfrcolor(frc : byte);
begin
    FR_COLOR := frc;
    setcolourmode($ff, FR_COLOR);
end;


procedure ginit;

    procedure set_lio_vector;
    var
       i      : integer;
       seglio : word;
    begin
        seglio := $f990;
        for i := 0 to 15 do
        begin
            memw[0000:($a0+i)*4] := memw[seglio:6+i*4];
            memw[0000:($a0+i)*4+2] := seglio
        end;
        memw[0000:$ce*4]   := memw[seglio:70];
        memw[0000:$ce*4+2] := seglio;
        memw[0000:$c5*4]   := memw[0000:$06*2];
        memw[0000:$c5*4+2] := memw[0000:$07*2]
    end;

begin { ginit }
    set_lio_vector;
    segbase := dseg + ofs(workarea) div 16;
    offset  := ofs(workarea) mod 16;
{    regs.ds := segbase;
    intr($a0, regs); }
    glio($a0);

    setscreenmode(1, 0);
    setcolourmode(0, 7);
    setscreenmode(0, 0);
    setcolourmode(0, 7);
    cleardevice;
    cleartextscreen;
    fkeyoff;
    graphdefaults;
end; {ginit}


procedure gclose;
begin
    setscreenmode(1, 0);
    setcolourmode(0, 7);
    setscreenmode(0, 0);
    setcolourmode(0, 7);
    cleartextscreen;
    fkeyon;
    cursoron;
end;


procedure setviewport(x1, y1, x2, y2 : integer);
begin
    PARAM[1] := lo(x1);
    PARAM[2] := hi(x1);
    PARAM[3] := lo(y1);
    PARAM[4] := hi(y1);
    PARAM[5] := lo(x2);
    PARAM[6] := hi(x2);
    PARAM[7] := lo(y2);
    PARAM[8] := hi(y2);
    PARAM[9] := BK_COLOR;
    PARAM[10]:= 0;
    glio($a2)
end;


procedure setpalette(pal, col : byte);
begin
    PARAM[1] := pal;
    PARAM[2] := color_code[col];
    glio($a4)
end;


procedure putpixel(x, y : integer; drc : byte);
begin
    CPX := x;
    CPY := y;
    x := x + X_0;
    y := round(y * 2 * (0.5 - Y_FLAG) * Y_SCALE) + Y_0;
    PARAM[1] := lo(x);
    PARAM[2] := hi(x);
    PARAM[3] := lo(y);
    PARAM[4] := hi(y);
    PARAM[5] := drc;
    glio($a6)
end;


procedure line(x1, y1, x2, y2 : integer);
begin
    CPX := x2;
    CPY := y2;
    x1 := x1 + X_0;
    y1 := round(y1 * 2 * (0.5 - Y_FLAG) * Y_SCALE) + Y_0;
    x2 := x2 + X_0;
    y2 := round(y2 * 2 * (0.5 - Y_FLAG) * Y_SCALE) + Y_0;
    PARAM[1] := lo(x1);
    PARAM[2] := hi(x1);
    PARAM[3] := lo(y1);
    PARAM[4] := hi(y1);
    PARAM[5] := lo(x2);
    PARAM[6] := hi(x2);
    PARAM[7] := lo(y2);
    PARAM[8] := hi(y2);
    PARAM[9] := DRAW_COLOR;
    PARAM[10] := lo(LINE_SW);
    PARAM[11] := hi(LINE_SW);
    PARAM[12] := lo(LINE_PTN);
    PARAM[13] := hi(LINE_PTN);
    glio($a7)
end;


procedure rectangle(x1, y1, x2, y2 : integer);
begin
    CPX := x2;
    CPY := y2;
    x1 := x1 + X_0;
    y1 := round(y1 * 2 * (0.5 - Y_FLAG) * Y_SCALE) + Y_0;
    x2 := x2 + X_0;
    y2 := round(y2 * 2 * (0.5 - Y_FLAG) * Y_SCALE) + Y_0;
    PARAM[1] := lo(x1);
    PARAM[2] := hi(x1);
    PARAM[3] := lo(y1);
    PARAM[4] := hi(y1);
    PARAM[5] := lo(x2);
    PARAM[6] := hi(x2);
    PARAM[7] := lo(y2);
    PARAM[8] := hi(y2);
    PARAM[9] := DRAW_COLOR;
    PARAM[10] := lo(RECT_SW);
    PARAM[11] := hi(RECT_SW);
    PARAM[12] := lo(LINE_PTN);
    PARAM[13] := hi(LINE_PTN);
    PARAM[14] := FILLPTNSIZE;
    PARAM[15] := lo(FILLPTNOFF);
    PARAM[16] := hi(FILLPTNOFF);
    PARAM[17] := lo(segbase);
    PARAM[18] := hi(segbase);
    glio($a7)
end;


procedure circle(x0, y0, r : integer);
var
    ry : integer;
begin
    CPX := x0;
    CPY := y0;
    x0 := x0 + X_0;
    y0 := round(y0 * 2 * (0.5 - Y_FLAG) * Y_SCALE) + Y_0;
    ry := round(r * Y_SCALE);
    PARAM[1] := lo(x0);
    PARAM[2] := hi(x0);
    PARAM[3] := lo(y0);
    PARAM[4] := hi(y0);
    PARAM[5] := lo(r);
    PARAM[6] := hi(r);
    PARAM[7] := lo(ry);
    PARAM[8] := hi(ry);
    PARAM[9] := DRAW_COLOR;
    PARAM[10] := CIRC_SW;
    PARAM[19] := FILLPTNSIZE;
    PARAM[20] := lo(FILLPTNOFF);
    PARAM[21] := hi(FILLPTNOFF);
    PARAM[22] := lo(segbase);
    PARAM[23] := hi(segbase);
    glio($a8)
end;


procedure ellipse(x, y, rx, ry : integer);
begin
    CPX := x;
    CPY := y;
    x  := x + X_0;
    y  := round(y * 2 * (0.5 - Y_FLAG) * Y_SCALE) + Y_0;
    ry  := round(ry * Y_SCALE);
    PARAM[1] := lo(x);
    PARAM[2] := hi(x);
    PARAM[3] := lo(y);
    PARAM[4] := hi(y);
    PARAM[5] := lo(rx);
    PARAM[6] := hi(rx);
    PARAM[7] := lo(ry);
    PARAM[8] := hi(ry);
    PARAM[9] := DRAW_COLOR;
    PARAM[10] := CIRC_SW;
    PARAM[19] := FILLPTNSIZE;
    PARAM[20] := lo(FILLPTNOFF);
    PARAM[21] := hi(FILLPTNOFF);
    PARAM[22] := lo(segbase);
    PARAM[23] := hi(segbase);
    glio($a8)
end;


procedure floodfill(x, y : integer; bdc : byte);
begin
    x := x + X_0;
    y := round(y * 2 * (0.5 - Y_FLAG) * Y_SCALE) + Y_0;
    PARAM[1] := lo(x);
    PARAM[2] := hi(x);
    PARAM[3] := lo(y);
    PARAM[4] := hi(y);
    if FILL_SW = 0 then
    begin
        PARAM[5] := FILLPTNSIZE;
        PARAM[6] := bdc;
        PARAM[7] := lo($0a00);
        PARAM[8] := hi($0a00);
        PARAM[9] := lo($06a0);
        PARAM[10] := hi($06a0);
        glio($aa)
    end
    else
    begin
        PARAM[6] := FILLPTNSIZE;
        PARAM[7] := lo(FILLPTNOFF);
        PARAM[8] := hi(FILLPTNOFF);
        PARAM[9] := lo(segbase);
        PARAM[10] := hi(segbase);
        PARAM[11] := bdc;
        PARAM[17] := lo($0a00);
        PARAM[18] := hi($0a00);
        PARAM[19] := lo($06a0);
        PARAM[20] := hi($06a0);
        glio($aa)
    end
end;


procedure getimage(x1, y1, x2, y2 : integer; buf : word);
begin
    IMAGE_SIZE := ((x2 - x1 + 8) div 8) * (y2 - y1 + 1) * 4 + 4;
    PARAM[1]  := lo(x1);
    PARAM[2]  := hi(x1);
    PARAM[3]  := lo(y1);
    PARAM[4]  := hi(y1);
    PARAM[5]  := lo(x2);
    PARAM[6]  := hi(x2);
    PARAM[7]  := lo(y2);
    PARAM[8]  := hi(y2);
    PARAM[9]  := lo(buf);
    PARAM[10] := hi(buf);
    PARAM[11] := lo(segbase);
    PARAM[12] := hi(segbase);
    PARAM[13] := lo(IMAGE_SIZE);
    PARAM[14] := hi(IMAGE_SIZE);
    glio($ab)
end;


procedure putimage(x, y : integer; buf : word; mode : byte);
begin
    PARAM[1]  := lo(x);
    PARAM[2]  := hi(x);
    PARAM[3]  := lo(y);
    PARAM[4]  := hi(y);
    PARAM[5]  := lo(buf);
    PARAM[6]  := hi(buf);
    PARAM[7]  := lo(segbase);
    PARAM[8]  := hi(segbase);
    PARAM[9]  := lo(IMAGE_SIZE);
    PARAM[10] := hi(IMAGE_SIZE);
    PARAM[11] := mode;
    PARAM[12] := $00;
    PARAM[13] := FR_COLOR;
    PARAM[14] := BK_COLOR;
    glio($ac)
end;


procedure putkanji(x, y : integer; code : word; mode : byte);
begin
    PARAM[1]  := lo(x);
    PARAM[2]  := hi(x);
    PARAM[3]  := lo(y);
    PARAM[4]  := hi(y);
    PARAM[5]  := lo(code);
    PARAM[6]  := hi(code);
    PARAM[7]  := mode;
    PARAM[8]  := $01;
    PARAM[9]  := FR_COLOR;
    PARAM[10] := BK_COLOR;
    glio($ad)
end;


procedure moveimage(x, y : integer);
begin
    PARAM[1] := lo(x);
    PARAM[2] := hi(x);
    PARAM[3] := lo(y);
    PARAM[4] := hi(y);
    PARAM[5] := $01;
    glio($ae)
end;


function getpixel(x, y : integer) : byte;
begin
    PARAM[1] := lo(x);
    PARAM[2] := hi(x);
    PARAM[3] := lo(y);
    PARAM[4] := hi(y);
    glio($af);
    getpixel := lo(regs.ax)
end;


procedure warp(leng : real);
begin
    LPX := LPX + leng * cos(ANGLE * PI / 180);
    LPY := LPY - leng * sin(ANGLE * PI / 180) * 2 * (0.5 - Y_FLAG)
end;


procedure setlp(tlpx, tlpy : real);
begin
    LPX := tlpx;
    LPY := tlpy
end;


procedure setangle(ang : real);
begin
    ANGLE := ang
end;


procedure turn(ang : real);
begin
    ANGLE := ANGLE + ang;
    ANGLE := ANGLE - round(ANGLE) + round(ANGLE) mod 360
end;


procedure move(leng : real);
var x, y : real;
begin
    x := LPX + leng * cos(ANGLE * PI / 180);
    y := LPY - leng * sin(ANGLE * PI / 180) * 2 * (0.5 - Y_FLAG);
    line(round(LPX), round(LPY), round(x), round(y));
    LPX := x;
    LPY := y
end;


end.
{ The end of Grapphics }