Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBII/ECO_FAST.PAS

Pascal/Delphi Source File | 1992-09-25 | 15.9 KB | 461 lines

(*
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   Unit was conceived, designed and written         ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   by Floor A.C. Naaijkens for                      ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   UltiHouse Software / The ECO Group.              ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   (C) MCMXCII by EUROCON PANATIONAL CORPORATION.   ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   All Rights Reserved for The ECO Group.           ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
*)
{$S-,R-,V-,D-}
unit eco_fast;
interface
uses
  dos

  ;


type
  _vectoraddr = record _ofs: word; _seg : word end;
  _scnpos = record _ch : char; _attr : byte end;
  _scnimage    = array[1..4000] of _scnpos;
  _scnimageptr = ^_scnimage;
  str80 = string[80];
  _monitortype = (
    _nomonitor,
    _monomonitor,      { monochrome monitor             }
    _colormonitor,     { color monitor (composite also) }
    _enhancedmonitor,  { ega rnhanced color monitor     }
    _anmonomonitor,    { ps/2 analog monochrome monitor }
    _ancolormonitor    { ps/2 analog color monitor      }
  );


const
  _hidemouse : boolean = true;
  _video = $10;
  fcol: byte = 7;
  bcol: byte = 0;
  bt_double    = 15;     bt_single    =   0;
  black        = 00;     blue         = 01;
  green        = 02;     cyan         = 03;
  red          = 04;     magenta      = 05;
  brown        = 06;     lightgray    = 07;
  darkgray     = 08;     lightblue    = 09;
  lightgreen   = 10;     lightcyan    = 11;
  lightred     = 12;     lightmagenta = 13;
  yellow       = 14;     white        = 15;
  blink        = 128;

  _unknown     = $7f;
  _absent      = 0;                 { no adapter installed           }
  _mono        = 1;                 { monochrome type adapter        }
  _color       = 2;                 { color type adapter             }

  _biosseg     = $0040;             { segment of bios/dos communica- }


var
  baseofscreen : word;                    {base address of video memory}
  vseg : word;
  vofs : word;
  rows : word;
  cols : word;

  _scnloc         : _scnimageptr;    { screen adapter memory location }
  _curcolumns     : byte;            { number of screen columns       }
  _currows        : byte;            { number of screen rows          }
  _curmode        : byte;            { current video display mode     }
  _curdevice      : byte;            { _mono or _color device         }
  _curmonitor     : _monitortype;    { monitor attached to _curdevice }
  _maxdisplaypage : byte;            { maximum display page number    }
  _curdisplaypage : byte;            { current video display page     }
  _curactivepage  : byte;            { current video active page      }
  _monoadapter    : byte;            { monochrome adapter             }
  _coloradapter   : byte;            { color/graphics adapter         }
  _egaadapter     : byte;            { ega adapter                    }
  _hercadapter    : byte;            { hercules mono graphics card    }
  _vgaadapter     : byte;            { ps/2 video graphics array      }
  _mcgaadapter    : byte;            { ps/2 model 30 adapter          }
  _scrolltab      : word;            { spaces to skip for tab scroll  }
  _tabincr        : word;            { tab increment for _txbufscn    }
  _bufindent      : word;            { left margin for _txbufscn      }

  {scnstate_         : scnstat_;    }  { bios video save information    }
  {availcolormodes_  : videomodes_; }  { modes available on color device}
  {availmonomodes_   : videomodes_; }  { modes available on mono device }
  {availcolorrows_   : legalrows_;  }  { rows available on color device }
  {availmonorows_    : legalrows_;  }  { rows available on mono device  }
  {dualdisplay_      : boolean;     }  { two adapters present           }
  egamonitor_       : _monitortype;  { monitor attached: ega          }
  analogmonitor_    : _monitortype;  { monitor attached: vga/mcga     }
  egamemory_        : word;          { 64, 128, 192, or 256 (k)       }
  maxscanline_      : byte;          { current character set size     }



function  at(f, b: byte): byte;
procedure __scn(col, row, attr: byte; st: str80);
procedure __vid(col, row:       byte; st: str80);
procedure changeattr(col,row,attr: byte; number: word);
function  get_video_mode: byte;

{ extended functions, just like in eco_vid, but for small use }
procedure __attrib(x1, y1, x2, y2, f, b: byte);
procedure __bandwin(del: boolean; x1,y1,x2,y2,f,b,bt: byte);
procedure __betwscn(x1, x2, y, f, b: byte; st: string);
procedure __boxscn(x1,y1,x2,y2,boxtype,fore,back : byte);
procedure __clrscn(x1, y1, x2, y2, f, b: byte; c: char);
procedure __cls;
procedure __copyscn(x1, y1, x2, y2, x, y: byte);
function  __rep(n: byte; character: char): string;
function  __retdvscn(var mode, cols, rows, activepage, displaypage: byte): byte;
procedure __vert(x, y, f, b: byte; s: string);
procedure __write(col, row, f, b: byte; st: str80);


implementation



  function __rep(n: byte; character: char): string;
  var tempstr: string;
  begin
    if n = 0 then tempstr := '' else begin
      if (n > 255) then n := 1; fillchar(tempstr,n+1,character);
      tempstr[0] := chr(n);
    end; __rep := tempstr;
  end;


  {$F+}
  {$L ECO_FAST.OBJ}
  function at(f,b:byte): byte; begin at := (b shl 4) or f end;
  procedure __scn(col,row,attr:byte; st: str80); external;
  procedure __vid(col,row:     byte; st: str80); external;
  procedure changeattr(col,row,attr:byte; number:word); external;
  procedure __speedscn(
    sourceptr,targetptr : pointer;
        count,option,attribute : word;
        wait : boolean
  ); external;
  {$F-}


  function __retdvscn(var mode, cols, rows, activepage, displaypage: byte): byte;
  var
    reg         : registers;
    charheight  : word;

  begin
    with reg do begin
      ax := $0f00; intr(_video,reg); mode := al; cols := ah; activepage := bh
    end;
    if (mode = 7) then begin
      _curdevice := _mono;
      _scnloc    := ptr($b000,$0000)
    end else if (mode < 13) then begin
      _curdevice := _color;
      _scnloc    := ptr($b000,$8000)
    end else begin
      if (mode = 15) then _curdevice := _mono else _curdevice := _color;
      _scnloc := ptr($a000,$0000)
    end;
    with reg do begin
      es := _vectoraddr(_scnloc)._seg;
      di := _vectoraddr(_scnloc)._ofs;
      ah := $fe;
      intr(_video,reg);
      inline($fb);
      _scnloc := ptr(es,di)
    end;
    if ((_curdevice = _hercadapter) or (_curdevice = _monoadapter)) then begin
      _curmonitor := _monomonitor;
      charheight  := 14
    end else if (_curdevice = _coloradapter) then begin
      _curmonitor := _colormonitor;
      charheight  := 8
    end else if (
      _curdevice = _egaadapter
    ) then _curmonitor := egamonitor_ else if (
      (_curdevice = _vgaadapter) or
      (_curdevice = _mcgaadapter)
    ) then _curmonitor := analogmonitor_ else _curmonitor := _nomonitor;
    if (
      (_egaadapter = _curdevice) or (_mcgaadapter = _curdevice) or
      (_vgaadapter = _curdevice)
    ) then with reg do begin
      ax := $1130;
      bx := 0;
      intr(_video,reg);
      rows := dl + 1;
      charheight := cx
    end else rows := 25;
    case mode of
      4..6,8..10,17..19: _maxdisplaypage := 0;
      0,1: if (rows = 50) then _maxdisplaypage := 6 else _maxdisplaypage := 7;
      2,3,7: begin
        if (_curdevice = _mono) then _maxdisplaypage := 0 else
          _maxdisplaypage := 3;
        if (_curdevice = _vgaadapter) then case rows of
          25    : _maxdisplaypage := 7;
          43,50 : _maxdisplaypage := 3
        end;
        if (_curdevice = _egaadapter) then begin
          if (egamemory_ > 64) then _maxdisplaypage := 7 else
            _maxdisplaypage := 3;
          if (rows = 43) then _maxdisplaypage := _maxdisplaypage div 2
        end
      end;
      13: begin
        _maxdisplaypage := 7;
        if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
          _maxdisplaypage := 1 else if (egamemory_ = 128) then
          _maxdisplaypage := 3;
      end;
      14: begin
        _maxdisplaypage := 3;
        if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
          _maxdisplaypage := 0 else if (egamemory_ = 128) then
          _maxdisplaypage := 1
      end;
      15..16: begin
        _maxdisplaypage := 1;
        if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
          _maxdisplaypage := 0;
      end;
    end;

    displaypage    := _curdisplaypage;
    _curmode       := mode;
    _currows       := rows;
    _curcolumns    := cols;
    _curactivepage := activepage;
    maxscanline_   := charheight - 1;
    __retdvscn     := _curdevice
  end;


  function get_video_mode:byte;
  var regs : registers;
  begin
   with regs do begin
     ax := $0f00; intr($10,regs); get_video_mode := al;
   end; {with}
  end; {of proc video_mode}


  procedure __movescn(
    x1, y1, x2, y2: byte; bufferptr: pointer; toscreen: boolean
  );
  var
    bufptr      : _scnimageptr absolute bufferptr;
    scnptr      : _scnimageptr;
    pagelength  : word absolute _biosseg:$004c;
    offset      : word;                { offset into video buffer       }
    width       : word;                { width, in pairs, of each line  }
    delta       : word;                { increment between data lines   }
    lines       : word;                { number of lines to access      }
    wait        : boolean;
    i,j,k       : word;

  begin {__movescn}
    if ((_curmode > 3) and (_curmode <> 7)) then exit; { not textmode }
    if (x1 < 1) then x1 := 1 else if (x1 > _curcolumns) then x1 := _curcolumns;
    if (y1 < 1) then y1 := 1 else if (y1 > _currows) then y1 := _currows;
    if (x2 < x1) then x2 := x1 else if (x2>_curcolumns) then x2 := _curcolumns;
    if (y2 < y1) then y2 := y1 else if (y2 > _currows) then y2 := _currows;
    offset := ((y1 - 1) * _curcolumns) + x1;
    width  := x2 - x1 + 1; delta  := _curcolumns - x2 + x1 - 1;
    lines  := y2 - y1 + 1;
    if (_curdisplaypage <> 0) then scnptr := ptr(
      _vectoraddr(_scnloc)._seg,
     _vectoraddr(_scnloc)._ofs + (pagelength * _curdisplaypage)
    ) else scnptr := _scnloc;
    wait := false;

    j := offset; k := 1;
    for i := 1 to lines do begin
      if (toscreen) then __speedscn(
        @bufptr^[k], @scnptr^[j], width, 2, 0, wait
      ) else __speedscn(
        @scnptr^[j], @bufptr^[k], width, 3, 0, wait
      );
      inc(j,width + delta);
      inc(k,width);
    end
  end; { __movescn }



  procedure __boxscn(x1,y1,x2,y2,boxtype,fore,back : byte);
  const
    corners : array[1..4,0..3] of char = (
      (#218,#214,#213,#201),   { top left corner        }
      (#191,#184,#183,#187),   { top right corner       }
      (#192,#211,#212,#200),   { bottom left    }
      (#217,#189,#190,#188)    { bottom right   }
    );

    lines : array[1..2,0..1] of char = (
      (#196,#205),                 { horizontal         }
      (#179,#186)
    );                             { vertical           }


  var
    boxcorner     : array[1..4] of char;
    boxline       : array[1..4] of char;
    boxchar       : char;
    horchars      : byte;
    verchars      : byte;
    i             : word;
    cursoron      : boolean;
    x,y,xtop,xbot : byte;

  begin
    if (boxtype > 15) then begin
      boxchar := chr(boxtype);
      fillchar(boxcorner,4,boxchar);
      fillchar(boxline,4,boxchar)
    end else begin
      boxcorner[1] := corners[1,(boxtype and 3)];
      boxcorner[2] := corners[2,((boxtype shr 1) and 3)];
      boxcorner[3] := corners[3,
          ((boxtype and 1) or ( 2 * ((boxtype shr 3) and 1)))];
      boxcorner[4] := corners[4,((boxtype shr 2) and 3)];
      boxline[1]   := lines[1,((boxtype shr 1) and 1)];
      boxline[2]   := lines[1,((boxtype shr 3) and 1)];
      boxline[3]   := lines[2,(boxtype and 1)];
      boxline[4]   := lines[2,((boxtype shr 2) and 1)]
    end;
    horchars := x2 - x1 - 1; verchars := y2 - y1 - 1;
    __write(x1, y1, fore, back, boxcorner[1]);
    if (horchars > 0) then __write(x1 + 1, y1, fore, back, __rep(horchars, boxline[1]));
    __write(x2, y1, fore, back, boxcorner[2]);
    for i := 1 to verchars do begin
      __write(x1, y1 + i, fore, back, boxline[3]);
      __write(x2, y1 + i, fore, back, boxline[4])
    end;
    __write(x1, y2, fore, back, boxcorner[3]);
    if (horchars > 0) then __write(
      x1 + 1, y2, fore,back, __rep(horchars, boxline[2])
    );
    __write(x2, y2, fore, back, boxcorner[4]);
  end;   { __boxscn }


  procedure __write(col, row, f, b: byte; st: str80);
  begin
    __scn(col, row, at(f, b), st);
  end;


  procedure __attrib(x1, y1, x2, y2, f, b: byte);
  var i: byte;
  begin
    for i := y1 to y2 do changeattr(x1, i, at(f, b), succ(x2-x1))
  end;



  procedure __bandwin(del: boolean; x1, y1, x2, y2, f, b, bt: byte);
  var
    br, ht,
    vt, mih,
    miv      : byte;

  begin
    if del then begin
      miv := y1 + (y2-y1) div 2; mih := x1 + (x2-x1) div 2;
      if y2-y1>5 then vt := 2 else vt := 1;
      if x2-x1>20 then ht := 5 else ht := 3;
      __clrscn(mih - ht, miv - vt + 1, mih + ht, miv + vt, f, b, ' ');
      __boxscn(mih - ht, miv - vt + 1, mih + ht, miv + vt, 15, f, b);
    end;
    if bt=1 then br := 00 else br := 15;
    if _currows = 25 then begin
      __attrib(x1-1, y2+2, x2+5, y2+2, lightgray, black);
      __attrib(x2+2, y1, x2+5, y2+2, lightgray, black);
      __clrscn(x1-3, y1-1, x2+3, y2+1, f, b, ' ');
    end else begin
      __attrib(x1, y2+2, x2+2, y2+2, lightgray, black);
      __attrib(x2+1, y1, x2+2, y2+2, lightgray, black);
      __clrscn(x1-1, y1-1, x2+1, y2+1, f, b, ' ');
    end;
    __boxscn(x1, y1, x2, y2, br, f, b);
  end;


  procedure __vert(x, y, f, b: byte; s: string);
  var i: byte;
  begin
    for i := 1 to length(s) do __write(x, y + i - 1, f, b, s[i]);
  end;


  procedure __betwscn(x1, x2, y, f, b: byte; st: string);
  var x : integer;

  begin
    if length(st) >= x2 - x1 + 1 then __write(x1, y, f, b, st) else begin
      x := x1 + (x2 - x1 + 1 - length(st)) div 2;
      __write(x, y, f, b, st);
    end;
  end;


  procedure __clrscn(x1, y1, x2, y2, f, b: byte; c: char);
  var
    y      : integer;

  begin
    if x2 > 80 then x2 := 80;
    for y := y1 to y2 do __write(x1, y, f, b, __rep(x2-x1+1, c));
  end;



  procedure __cls;
  begin
    __clrscn(1, 1, _curcolumns, _currows, 7, 0, ' ');
  end;


  procedure __copyscn(x1, y1, x2, y2, x, y: byte);
  var buffer: _scnimage;
  begin
    __movescn(x1, y1, x2, y2, @buffer, false);
    __movescn(x, y, x+x2-x1, y+y2-y1, @buffer, true);
  end;


  procedure initquickwriteunit;
  begin
    if get_video_mode = 7 then baseofscreen := $b000 else baseofscreen := $b800;
    vseg := baseofscreen; vofs := 0;
  end;


begin
  initquickwriteunit;
  _curdisplaypage := 0;
  _curdevice := __retdvscn(
    _curmode,_curcolumns,_currows,
        _curactivepage,_curdisplaypage
  );
end.