unit CrtPlus;
{Jesna se o primitivni rozsirujici jednotku nad unit Crt, ktery usnadnuje
 pouziti nekterych vybranych funkci. Jednotka se zamerne nebude prilis
 rozsirovat a bude omezena jen na interakci s unitem Crt.
 Pro funkce nad ramec tohoto pouzij jednotku Lacrt (ta naopak Crt nepouziva)}

{$IFDEF FPC}
   {$CALLING OLDFPCCALL}
   {$ASMMODE INTEL}
   {$IFDEF VER2}{$DEFINE NEWFPC}{$ENDIF}
   {$IFDEF VER3}{$DEFINE NEWFPC}{$ENDIF}
{$ENDIF}

interface
uses Crt;

Procedure SetColors(a,b:byte);
Procedure writeXY(x,y:byte;s:string);
Procedure SchovejAtributy;
Procedure ObnovAtributy;
Function GetTextColor:byte;
Function GetBKcolor:byte;
Procedure StandartScreen;
Function SirkaObrazovky:byte;
Function VyskaObrazovky:byte;
Function TextAdressOffset(x,y:byte):word;
Procedure WriteDirect(s:string;styl:byte);
Procedure CopyFromTextScreen(ofset:word;var kam;bajtu:word);
Procedure CopyToTextScreen(ofset:word;var buf;bajtu:word);


implementation
type t_atributy = record
     x,y,at:byte;
     end;

const spec_col:byte = 1;
      writexy_NIC  = 0;
      writexy_TAB  = 1;
      writexy_CRLF = 2;
      writexy_END  = 3;
      writexy_SPEC = 4;


var t_atribut:t_atributy;   { slouzi pro ukladani pozice kurzoru a barev }
                            { popredi a pozadi }


Procedure SetColors(a,b:byte);
begin
TextColor(a);TextBackground(b);
end;


Procedure writeXY(x,y:byte;s:string);
begin
GotoXY(x,y);write(s);
end;


Procedure SchovejAtributy;
begin
t_atribut.x:=WhereX;t_atribut.y:=WhereY;
t_atribut.at:=TextAttr;
end;


Procedure ObnovAtributy;
begin
GotoXY(t_atribut.x,t_atribut.y);
TextAttr:=t_atribut.at;
end;


Function GetTextColor:byte;
begin
GetTextColor:=TextATTR and 15;
end;


Function GetBKcolor:byte;
begin
GetBKColor:=TextATTR and 112 shr 4;
end;


Procedure StandartScreen;
begin
NormVideo;TextColor(7);TextBackground(0);window(1,1,80,25);
asm
mov ah,5
mov al,0
int 10h
end;
end;


Function SirkaObrazovky:byte;
begin
SirkaObrazovky:=MemW[Seg0040:$4a];
end;


Function VyskaObrazovky:byte;
begin
VyskaObrazovky:=MemW[Seg0040:$4c] div MemW[Seg0040:$4a] div 2;
end;


Function TextAdressOffset(x,y:byte):word;
begin
TextAdressOffset:=((y-1)*SIRKAOBRAZOVKY+(x-1))*2;
end;


Procedure WriteDirect(s:string;styl:byte);
var a,b,c:byte;
        w:word;
begin
a:=WhereX;
b:=WhereY;
w:=Textadressoffset(a,b);
for c:=1 to byte(s[0]) do
  begin
  Mem[SegB800:w]:=byte(s[c]);
  Mem[SegB800:w+1]:=textattr;
  inc(w,2);
  end;
dec(w,2);
b:=w div (SIRKAOBRAZOVKY*2) + 1;
c:=(w mod (SIRKAOBRAZOVKY*2)) div 2 + 1;
{writeln(b);}
if styl = writexy_TAB then GotoXY(a,b+1)
   else if styl = writexy_CRLF then GotoXY(1,b+1)
           else if styl = writexy_END then GotoXY(c+1,b)
                   else if styl = writexy_SPEC then GotoXY(spec_col,b+1);
end;


Procedure CopyFromTextScreen(ofset:word;var kam;bajtu:word);
var a:word;
    p:^byte;
begin
p:=@kam;
for a:=1 to bajtu do
    begin
    p^:=Mem[SegB800:ofset];
    inc(p);
    inc(ofset);
    end;
end;


Procedure CopyToTextScreen(ofset:word;var buf;bajtu:word);
var a:word;
    p:^byte;
begin
p:=@buf;
for a:=1 to bajtu do
    begin
    Mem[SegB800:ofset]:=p^;
    inc(p);
    inc(ofset);
    end;
end;


Procedure Input(var s:string);
var c:char;
begin
repeat
repeat until Keypressed;
c:=Readkey;
case c of
#0:begin c:=Readkey;c:=#0;end;
#8{backspace}:if Length(s)>0 then
             begin
             delete(s,Length(s),1);write(#8);write(#32);write(#8);
             end;
#13{enter}:begin end;
else
     begin
     write(c);
     s:=s+c;
     end;
end;
until (c=#13{enter}) or (Length(s)=255);
end;


end.
