Programmer 7500/MAX_PROGRAMMERS.iso/INFO/ASM/GR110.ZIP/GR.INC

Text File | 1985-08-26 | 13.1 KB | 469 lines

{
       Graphics Routines
         Version 1.1.0
            8/16/85

     By Michael A. Quinlan

  See file GR.DOC for documentation
}

  Type GrString = String[80];      { general purpose string }
       _GrBuffT = array [0..32767] of byte;

  const _GrGraphMode : (_GrTextMode, _GrHGCMode, _GrCGAMode) = _GrTextMode;

  Var GrBytes   : integer;         { # bytes in the screen refresh buffer }
      GrWords   : integer;         { # words in the screen refresh buffer }
      GrBase    : integer;         { segment base for screen refresh buffer }
      GrBuffer  : ^_GrBuffT;       { ptr to screen refresh buffer }

      ScrMaxX    : integer;        { max X screen coordinate }
      ScrMaxY    : integer;        { max Y screen coordinate }
      ScrAspect  : real;           { screen aspect }

      WindX1     : integer;        { screen coord for U.L. corner of window }
      WindY1     : integer;
      WindMaxX   : integer;        { max X window coordinate }
      WindMaxY   : integer;        { max Y window coordinate }
      WindMaxRow : integer;        { max window row }
      WindMaxCol : integer;        { max window column }

      WorldX1    : real;           { World coord of U.L. corner of window }
      WorldY1    : real;
      WorldXRange: real;           { range of X values; X2-X1 }
      WorldYRange: real;           { range of Y values; Y2-Y1 }

      WhereX, WhereY : integer;

      _ScrWriteDot   : integer;
      _ScrReadDot    : integer;
      _ScrDrawLine   : integer;
      _ScrDrawChar   : integer;
      _GrFillWindow  : integer;
      _GrSaveWindow  : integer;
      _GrRestoreWindow : integer;

      _GrOldConOut   : integer;

procedure _Gr;               external 'GR.COM';  {*** DO NOT CALL ***}
function _GrHGCThere : boolean;   external _Gr[0];
function _GrCGAThere : boolean;   external _Gr[3];
procedure _GrInitHGC;        external _Gr[6];
procedure _GrInitCGA;        external _Gr[9];
procedure _GrTermHGC;        external _Gr[12];
procedure _GrTermCGA;        external _Gr[15];
procedure _ScrWriteDotHGC;   external _Gr[18];   {*** DO NOT CALL ***}
procedure _ScrWriteDotCGA;   external _Gr[21];   {*** DO NOT CALL ***}
procedure _ScrDrawLineHGC;   external _Gr[24];   {*** DO NOT CALL ***}
procedure _ScrDrawLineCGA;   external _Gr[27];   {*** DO NOT CALL ***}
procedure _GrFillWindowHGC;  external _Gr[30];   {*** DO NOT CALL ***}
procedure _GrFillWindowCGA;  external _Gr[33];   {*** DO NOT CALL ***}
procedure _ScrDrawCharHGC;   external _Gr[36];   {*** DO NOT CALL ***}
procedure _ScrDrawCharCGA;   external _Gr[39];   {*** DO NOT CALL ***}
procedure _GrSaveWindowHGC;  external _Gr[42];   {*** DO NOT CALL ***}
procedure _GrSaveWindowCGA;  external _Gr[45];   {*** DO NOT CALL ***}
procedure _GrRestoreWindowHGC; external _Gr[48]; {*** DO NOT CALL ***}
procedure _GrRestoreWindowCGA; external _Gr[51]; {*** DO NOT CALL ***}
function _GrOutcode(x, y, XMax, YMax : integer) : integer;
  external _Gr[54];
procedure _ScrReadDotHGC;    external _Gr[57];   {*** DO NOT CALL ***}
procedure _ScrReadDotCGA;    external _Gr[60];   {*** DO NOT CALL ***}
procedure _GrISwap(var i, j : integer); external _Gr[63];

procedure _GrGotoXY(x, y : integer);
  begin
    GotoXY(x, y)
  end;

procedure _GrClrScr;
  begin
    ClrScr;
    WhereX := 1;
    WhereY := 1
  end;

procedure _GrClrEol;
  begin
    ClrEol
  end;

procedure ScrDrawChar(x, y : integer; c : char);
  begin
    Inline($FF/$26/_ScrDrawChar)   { Jmp [_ScrDrawChar] }
  end;

procedure ScrWriteDot(x, y, color : integer);
  begin
    Inline($FF/$26/_ScrWriteDot)   { Jmp [_ScrWriteDot] }
  end;

function ScrReadDot(x, y : integer) : integer;
  begin
    Inline($FF/$26/_ScrReadDot)    { Jmp [_ScrReadDot] }
  end;

procedure ScrDrawLine(x1, y1, x2, y2, color : integer);
  var m, b : real;
      i    : integer;
  begin
    Inline($FF/$26/_ScrDrawLine)   { Jmp [_ScrDrawLine] }
  end;

procedure ScrDrawText(x, y : integer; t : GrString);
  var i : integer;
  begin
    for i := 1 to length(t) do begin
      ScrDrawChar(x, y, t[i]);
      x := x + 8
    end
  end;

procedure ScrDrawBox(x1, y1, x2, y2, color : integer);
  begin
    ScrDrawLine(x1, y1, x2, y1, color);
    ScrDrawLine(x2, y1, x2, y2, color);
    ScrDrawLine(x2, y2, x1, y2, color);
    ScrDrawLine(x1, y2, x1, y1, color)
  end;

procedure WindWriteDot(x, y, color : integer);
  begin
    if (x >= 0) and (x <= WindMaxX) and (y >= 0) and (y <= WindMaxY) then
      ScrWriteDot(x + WindX1, y + WindY1, color)
  end;

function WindReadDot(x, y : integer) : integer;
  begin
    if (x < 0) or (x > WindMaxX) or (y < 0) or (y > WindMaxY) then
      WindReadDot := 0
    else WindReadDot := ScrReadDot(x + WindX1, y + WindY1)
  end;

function _WindClipLine(var x1, y1, x2, y2 : integer) : boolean;

{ Cohen-Sutherland Clipping Algorithm
  See "Fundamentals of Interactive Computer Graphics" p. 148 }

  var done : boolean;
      outcode1, outcode2 : integer;
  begin
    done := FALSE;
    _WindClipLine := FALSE;
    outcode2 := _GrOutcode(x2, y2, WindMaxX, WindMaxY);
    repeat
      outcode1 := _GrOutcode(x1, y1, WindMaxX, WindMaxY);
      if (outcode1 or outcode2) = 0 then begin
        _WindClipLine := TRUE;
        done := TRUE
      end else if (outcode1 and outcode2) <> 0 then begin
        _WindClipLine := FALSE;
        done := TRUE
      end else begin
        if outcode1 = 0 then begin
          _GrISwap(outcode1, outcode2);
          _GrISwap(x1, x2);
          _GrISwap(y1, y2)
        end;
        if (outcode1 and $01) <> 0 then begin
          x1 := x1 + (x2 - x1) * Trunc((WindMaxY - y1) / (y2 - y1));
          y1 := WindMaxY
        end else if (outcode1 and $02) <> 0 then begin
          x1 := x1 + (x2 - x1) * Trunc((-y1) / (y2 - y1));
          y1 := 0
        end else if (outcode1 and $04) <> 0 then begin
          y1 := y1 + (y2 - y1) * Trunc((WindMaxX - x1) / (x2 - x1));
          x1 := WindMaxX
        end else if (outcode1 and $08) <> 0 then begin
          y1 := y1 + (y2 - y1) * Trunc((-x1) / (x2 - x1));
          x1 := 0
        end
      end
    until done
  end;

procedure WindDrawLine(x1, y1, x2, y2, color : integer);
  begin
    if _WindClipLine(x1, y1, x2, y2) then
      ScrDrawLine(x1 + WindX1, y1 + WindY1, x2 + WindX1, y2 + WindY1, color)
  end;

procedure WindDrawBox(x1, y1, x2, y2, color : integer);
  var DrawTop, DrawBot, DrawLeft, DrawRight : boolean;

  begin
    if x1 > x2 then _GrISwap(x1, x2);
    if y1 > y2 then _GrISwap(y1, y2);

    if x1 > WindMaxX then exit;
    if y1 > WindMaxY then exit;
    if x2 < 0 then exit;
    if y2 < 0 then exit;

    DrawTop := TRUE;
    DrawBot := TRUE;
    DrawLeft := TRUE;
    DrawRight := TRUE;

    if x1 < 0 then begin
      x1 := 0;
      DrawLeft := FALSE
    end;
    if y1 < 0 then begin
      y1 := 0;
      DrawTop := FALSE
    end;
    if x2 > WindMaxX then begin
      x2 := WindMaxX;
      DrawRight := FALSE
    end;
    if y2 > WindMaxY then begin
      y2 := WindMaxY;
      DrawBot := FALSE
    end;

    x1 := x1 + WindX1;
    x2 := x2 + WindX1;
    y1 := y1 + WindY1;
    y2 := y2 + WindY1;

    if DrawTop then ScrDrawLine(x1, y1, x2, y1, color);
    if DrawRight then ScrDrawLine(x2, y1, x2, y2, color);
    if DrawBot then ScrDrawLine(x2, y2, x1, y2, color);
    if DrawLeft then ScrDrawLine(x1, y2, x1, y1, color)
  end;

procedure WindDrawChar(x, y : integer; c : char);
  begin
    x := (x + 7) and $FFF8;
    if x < 0 then exit;
    if (x + 7) > WindMaxX then exit;
    if y < 0 then exit;
    if (y + 7) > WindMaxY then exit;
    ScrDrawChar(x + WindX1, y + WindY1, c)
  end;

procedure WindDrawText(x, y : integer; t : GrString);
  var i : integer;
  begin
    for i := 1 to length(t) do begin
      WindDrawChar(x, y, t[i]);
      x := x + 8
    end
  end;

function _WorldToWindowX(x : real) : integer;
  begin
    _WorldToWindowX := Round(((x - WorldX1) * WindMaxX) / WorldXRange)
  end;

function _WorldToWindowY(y : real) : integer;
  begin
    _WorldToWindowY := Round(((y - WorldY1) * WindMaxY) / WorldYRange)
  end;

procedure WorldWriteDot(x, y : real; color : integer);
  begin
    WindWriteDot(_WorldToWindowX(x), _WorldToWindowY(y), color)
  end;

function WorldReadDot(x, y : real) : integer;
  begin
    WorldReadDot := WindReadDot(_WorldToWindowX(x), _WorldToWindowY(y))
  end;

procedure WorldDrawLine(x1, y1, x2, y2 : real; color : integer);
  begin
    WindDrawLine(_WorldToWindowX(x1), _WorldToWindowY(y1),
                 _WorldToWindowX(x2), _WorldToWindowY(y2), color)
  end;

procedure WorldDrawBox(x1, y1, x2, y2 : real; color : integer);
  begin
    WindDrawBox(_WorldToWindowX(x1), _WorldToWindowY(y1),
                _WorldToWindowX(x2), _WorldToWindowY(y2), color)
  end;

procedure WorldDrawChar(x, y : real; c : char);
  begin
    WindDrawChar(_WorldToWindowX(x), _WorldToWindowY(y), c)
  end;

procedure WorldDrawText(x, y : real; t : GrString);
  begin
    WindDrawText(_WorldToWindowX(x), _WorldToWIndowY(y), t)
  end;

procedure GotoXY(x, y : integer);
  begin
    WhereX := x;
    WhereY := y;
    if _GrGraphMode = _GrTextMode then _GrGotoXY(x, y)
  end;

procedure ClrScr;
  begin
    if _GrGraphMode = _GrTextMode then _GrClrScr
    else begin
      FillChar(GrBuffer^, GrBytes, 0);
      WhereX := 1;
      WhereY := 1
    end
  end;

procedure ClrEol;
  var i, x, y : integer;
  begin
    if _GrGraphMode = _GrTextMode then _GrClrEol
    else begin
      y := (WhereY - 1) * 8;
      x := (WhereX - 1) * 8;
      for i := WhereX to WindMaxCol do begin
        WindDrawChar(x, y, ' ');
        x := x + 8
      end
    end
  end;

procedure _GrBeep;
  begin
    Sound(1000);
    Delay(100);
    NoSound
  end;

procedure _GrScroll;
{ scroll the window up 1 line }
  begin
    WhereY := 1   { for now, forget about scrolling }
  end;

procedure _GrNewLine;
{ advance to the next line }
  begin
    if WhereY >= WindMaxRow then _GrScroll
    else WhereY := WhereY + 1;
    WhereX := 1
  end;

procedure _GrNextCol;
{ advance to the next column }
  begin
    if WhereX >= WindMaxCol then _GrNewLine
    else WhereX := WhereX + 1
  end;

procedure GrWriteChar(c : char);
  begin
    if (c >= ' ') and (c < Chr(127)) then begin
      WindDrawChar((WhereX - 1) * 8, (WhereY - 1) * 8, c);
      _GrNextCol
    end else case c of
      ^G : _GrBeep;
      ^J : _GrNewLine;
      ^M : WhereX := 1
    end
  end;

procedure GrWorld(x1, y1, x2, y2 : real);
  begin
    WorldX1 := x1;
    WorldY1 := y1;
    WorldXRange := x2 - x1;
    WorldYRange := y2 - y1
  end;

procedure GrWindow(x1, y1, x2, y2 : integer);
  begin
    x1 := (x1 + 7) and $7ff8;
    WindX1 := x1;
    WindY1 := y1;
    WindMaxX := x2 - x1;
    if WindMaxX < 7 then WindMaxX := 7;
    WindMaxY := y2 - y1;
    if WindMaxY < 1 then WindMaxY := 1;
    WindMaxRow := (WindMaxY + 1) div 8;
    WindMaxCol := (WindMaxX + 1) div 8;
    WhereX := 1;
    WhereY := 1;
    GrWorld(x1, y1, x2, y2)
  end;

procedure _GrDoInitHGC;
  begin
    ScrMaxX := 719;
    ScrMaxY := 347;
    ScrAspect := 0.75;
    GrBytes := $8000;
    GrWords := 16384;
    GrBase  := $B000;
    _ScrWriteDot     := Ofs(_ScrWriteDotHGC);
    _ScrReadDot      := Ofs(_ScrReadDotHGC);
    _ScrDrawLine     := Ofs(_ScrDrawLineHGC);
    _GrFillWindow    := Ofs(_GrFillWindowHGC);
    _ScrDrawChar     := Ofs(_ScrDrawCharHGC);
    _GrSaveWindow    := Ofs(_GrSaveWindowHGC);
    _GrRestoreWindow := Ofs(_GrRestoreWIndowHGC);
    _GrInitHGC;
    _GrGraphMode := _GrHGCMode
  end;

procedure _GrDoInitCGA;
  begin
    ScrMaxX := 639;
    ScrMaxY := 199;
    ScrAspect := 0.44;
    GrBytes := 16384;
    GrWords := 8192;
    GrBase  := $B800;
    _ScrWriteDot     := Ofs(_ScrWriteDotCGA);
    _ScrReadDot      := Ofs(_ScrReadDotCGA);
    _ScrDrawLine     := Ofs(_ScrDrawLineCGA);
    _GrFillWindow    := Ofs(_GrFillWindowCGA);
    _ScrDrawChar     := Ofs(_ScrDrawCharCGA);
    _GrSaveWindow    := Ofs(_GrSaveWindowCGA);
    _GrRestoreWindow := Ofs(_GrRestoreWindowCGA);
    _GrInitCGA;
    _GrGraphMode := _GrCGAMode
  end;

procedure GrInit;
  begin
    if _GrHGCThere then _GrDoInitHGC
    else if _GrCGAThere then _GrDoInitCGA
    else begin
      writeln('***GrInit: Graphics Adaptor Card not found');
      halt
    end;
    GrBuffer := Ptr(GrBase, 0);
    GrWindow(0, 0, ScrMaxX, ScrMaxY);
    GrWorld(0.0, 0.0, ScrMaxX, ScrMaxY);
    _GrOldConOut := ConOutPtr;
    ConOutPtr := Ofs(GrWriteChar)
  end;

procedure GrTerm;
  begin
    case _GrGraphMode of
      _GrHGCMode : _GrTermHGC;
      _GrCGAMode : _GrTermCGA
    end;
    _GrGraphMode := _GrTextMode;
    ConOutPtr := _GrOldConOut
  end;

procedure GrSaveWindow(var area; x1, y1, x2, y2 : integer);
  begin
    Inline($FF/$26/_GrSaveWindow)  { JMP [_GrSaveWindow] }
  end;

procedure GrRestoreWindow(x1, y1, x2, y2 : integer; var area);
  begin
    Inline($FF/$26/_GrRestoreWindow) { JMP [_GrRestoreWindow] }
  end;

procedure GrFillWindow(x1, y1, x2, y2, color : integer);
  begin
    Inline($FF/$26/_GrFillWindow)   { Jmp [_GrFillWindow] }
  end;