unit vdirekt;

interface

uses crt;

function dwherex:byte;

function dwherey:byte;

procedure dgotoxy(x,y:byte);

procedure dwrite(s:string);

procedure dwriteln(s:string);

procedure dtextbackground(f:byte);

procedure dtextcolor(f:byte);

procedure dsetcolors(f,b:byte);

procedure deltoeol;

procedure delbegline;

procedure delthisline;

procedure deltoendofscreen;

procedure deltobegofscreen;

procedure dclrscr;

procedure scrollup(firstline,lastline:integer);

procedure scrolldown(firstline,lastline:integer);


const linelen    : byte = 80;
      pagelen    : byte = 24;
      tablen     : byte = 8;


type bildinhalt = array[0..80*25*2] of byte;

procedure savewindow(var bi : bildinhalt);

procedure setwindow(var bi : bildinhalt);


implementation

const vseg       : word = $b800;
      farbattrib : word = (lightgray shl 8);
      xpos       : byte = 0;
      ypos       : byte = 0;

function dwherex : byte;
begin
    dwherex:=xpos+1;
end;

function dwherey : byte;
begin
    dwherey:=ypos+1;
end;

procedure dgotoxy(x,y:byte);
begin
    xpos:=x-1;
    ypos:=y-1;
    gotoxy(x,y);
end;


procedure scrollup(firstline,lastline:integer);
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    l:=160*(lastline-firstline)-1;
    offset := firstline*160 + page_ofs;
    for i:=0 to l do begin
        mem[vseg:(offset+i)] := mem[vseg:(offset+160+i)]
        end;
    offset := lastline*160 + page_ofs;
    for i:=0 to linelen-1 do memw[vseg:(offset+i*2)] := Farbattrib or 32;
end;

procedure scrolldown(firstline,lastline:integer);
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    l:=160*(lastline-firstline)-1;
    offset := firstline*160 + page_ofs;
    for i:=l downto 0 do begin
        mem[vseg:(offset+i+160)] := mem[vseg:(offset+i)]
        end;
    offset := firstline*160 + page_ofs;
    for i:=0 to linelen-1 do memw[vseg:(offset+i*2)] := Farbattrib or 32;
end;

procedure deltoeol;
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    l:=linelen-xpos-1;
    offset := xpos*2 + ypos*160 + page_ofs;
    for i:=0 to l do memw[vseg:(offset+2*i)] := Farbattrib + 32;
end;

procedure delbegline;
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    l:=xpos-1;
    offset := ypos*160 + page_ofs;
    for i:=0 to l do memw[vseg:(offset+2*i)] := Farbattrib + 32;
end;


procedure delthisline;
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i        : integer;
begin
    offset := ypos*160 + page_ofs;
    for i:=0 to linelen-1 do memw[vseg:(offset+2*i)] := Farbattrib + 32;
end;


procedure deltoendofscreen;
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    l := linelen*pagelen*2 - ypos*160 - xpos*2;
    offset := xpos*2 + ypos*160 + page_ofs;
    for i:=0 to l do memw[vseg:(offset+2*i)] := Farbattrib + 32;
end;


procedure deltobegofscreen;
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    l := ypos*160 + xpos*2 - 2 ;
    offset := page_ofs;
    for i:=0 to l do memw[vseg:(offset+2*i)] := Farbattrib + 32;
end;


procedure dclrscr;
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    offset := page_ofs;
    l      := linelen*pagelen-1;
    for i:=0 to l do begin
        memw[vseg:(offset+i*2)] := farbattrib + 32;
        end;
{
    xpos:=0;
    ypos:=0;
}
end;


procedure gotonextline(var offset:word);
begin
     inc(ypos);
     if ypos>=pagelen then begin
        scrollup(0,pagelen-1);
        ypos:=pagelen-1;
        dec(offset,linelen*2);
        end;
end;

procedure dwrite(s:string);
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : byte;
     c        : byte;
begin
   offset := ypos*160 + xpos*2 + page_ofs;
   l:=length(s);
   for i:=1 to l do begin
       c := ord(s[i]);
       if c=13 then begin
            xpos:=0;
            offset:=ypos*160+page_ofs;
            end
       else if c=10 then begin
            gotonextline(offset);
            end
       else if c=9 then begin
            xpos   := xpos + tablen - (xpos mod tablen);
            offset := ypos*160 + xpos*2 + page_ofs;
            end
       else if (c=8) or (c=$7F) then begin
            if xpos>0 then dec(xpos)
            else if ypos>0 then begin
                 xpos:=linelen-1;
                 dec(ypos);
                 end;
            offset := ypos*160 + xpos*2 + page_ofs;
            end
       else if c=7 then begin
            sound(700);
            delay(100);
            nosound;
            end
       else begin
            memw[vseg:offset] := farbattrib or c;
            inc(offset,2);
            inc(xpos);
            if xpos>=linelen then begin
               xpos:=0;
               gotonextline(offset);
               end;
            end;
       end;
   gotoxy(xpos+1,ypos+1);
end;

procedure dwriteln(s:string);
begin
    dwrite(s+#13+#10);
end;

procedure savewindow(var bi : bildinhalt);
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    offset := page_ofs;
    l      := linelen*pagelen*2;
    for i:=0 to l do bi[i] := mem[vseg:(offset+i)];
end;

procedure setwindow(var bi : bildinhalt);
var  page_ofs : word absolute $0040:$004E;
     offset   : word;
     i,l      : integer;
begin
    offset := page_ofs;
    l      := linelen*pagelen*2;
    for i:=0 to l do mem[vseg:(offset+i)] := bi[i];
end;





procedure dtextbackground(f:byte);
begin
    farbattrib := (farbattrib and $0F00) or (word(f) shl 12);
end;

procedure dtextcolor(f:byte);
begin
    farbattrib := (farbattrib and $F000) or (word(f) shl 8);
end;

procedure dsetcolors(f,b:byte);
begin
    farbattrib := (word(f) shl 8) or (word(b) shl 12);
end;




procedure vdirekt_init;
var crtc_port : word absolute $0040:$0063;
begin
    if crtc_port=$3b4 then vseg:=$b000
                      else vseg:=$b800;
end;

begin
    vdirekt_init;
end.