{ TRSEK.PAS                 Copyright (c) TrSek alias Zdeno Sekerak }
{ Unit pre zobrazovanie na obrazovku, citanie z klavesnice.         }
{                                                                   }
{ Datum:19.06.1995                            http://www.trsek.com  }
 
unit TRSEK;
interface
uses kniznic;
 var strana:array[1..2,1..80,1..24] of byte;
 procedure KurzorZap(ZapVyp:boolean);
 procedure farba(x,y:integer);
 function  tread(x,y:integer;d:byte;s,old:string;sedy,znak:char):string;
 procedure open_win(xl,yl,xp,yp:integer;text:string;color:integer);
 procedure vezmi(x1,y1,x2,y2:integer);
 procedure poloz(x1,y1,x2,y2:integer);
 procedure koniec(naz_prog,rok:string);
 function get_znak(x,y:byte;var farba:byte):byte;
 procedure put_znak(x,y,farba,znak:byte);
 procedure clear_keyb;
 
 implementation
 uses crt,dos;
 
procedure KurzorZap(ZapVyp:boolean);
  var
    Regs : Registers;
  begin
     with Regs do
     begin
        AH := $03;
        BH := $00;
        Intr($10,Regs);
        If not (Zapvyp) then
        CH := CH or $20
        else
        CH := CH and $DF;
        AH := $01;
        Intr($10,Regs);
     end;
  end;
 
procedure farba(x,y:integer);
begin
 if x in [0..15] then textbackground(x);
 if y in [0..15] then textcolor(y);
end;
 
function tread(x,y:integer;d:byte;s,old:string;sedy,znak:char):string;
  var s1,s2,sz:string;
     st:char;
     x1,i,ins:integer;
     prv:boolean;
     label tam;
 begin
   x1:=x;ins:=1;kurzorZap(true);prv:=true;
   if sedy=#255 then prv:=false;
   s:=copy(s,1,d);
   if length(s)<d then for i:=length(s) to d-1 do s:=s+' ';
   gotoxy(x,y);write(s);sz:=s;
   if (x>0) and (x<81) and (y>0) and (y<25) and(x+d<81) then
                              begin
                              gotoxy(x,y);
                              repeat
                              if not(prv) then st:=readkey
                                     else begin
                                       if sedy=#13 then begin
                                           prv:=false;st:=znak;
                                           end
                                          else st:=sedy;
                                      end;
 
         if (st=#27) or (st=#8) or (st=#0) or (st=#13) then
                  begin if st=#0 then
                           begin
                              if prv then st:=znak
                                     else st:=readkey;
                              prv:=false;
                              if st=#59 then s:=old;
                              if st=#75 then x1:=x1-1;
                              if st=#77 then x1:=x1+1;
                              if st=#71 then x1:=x;
                              if st=#79 then begin
                                               i:=d+1;x1:=x+d;
                                               repeat
                                                i:=i-1;
                                                s1:=copy(s,i,1);
                                                if (s1=' ') then x1:=x+i-1;
                                               until  (i=0) or (not(s1=' '));
                                              st:=#0;
                                             end;
                            end;
                        if st=#27 then begin gotoxy(x,y);write(sz);kurzorZap(false);tread:=sz;exit;end;
                        if st=#8  then begin s1:=copy(s,1,x1-x-1);
                                             s2:=copy(s,x1-x+1,d-x1+x);
                                             s:=s1+s2+' ';
                                             x1:=x1-1;
                                       end;
                        if st=#83 then begin s1:=copy(s,1,x1-x);
                                             s2:=copy(s,x1-x+2,d-x1+x);
                                             s:=s1+s2+' ';
                                       end;
                        if st=#82 then begin if ins=2 then ins:=1
                                                      else ins:=2;
                                       end;
 
                  end
                  else begin
                             s1:=copy(s,1,x1-x);
                             s2:=copy(s,x1+ins-x,d-x1+x);
                             s:=s1+copy(st,1,1)+s2;
                             s:=copy(s,1,d);st:='a';
                             x1:=x1+1;if (x1>x+d) then x1:=x+d;
                      end;
        if x1<x then x1:=x;
        if x1>x+d then x1:=x+d;
        s:=copy(s,1,d);
        gotoxy(x,y);write(s);gotoxy(x1,y);
     until ( (st in [#13,#72,#80]) or ( ((x1-x) >= d) and (st in ['0'..'9','-','+','.','A'..'z'])) );
    tread:=s;farba(0,15);kurzorZap(false);
    end;
 end;
 
procedure open_win(xl,yl,xp,yp:integer;text:string;color:integer);
 var i,xs,ys:integer;
    p:real;
 begin
  owindow(xl,yl,xp,yp);
  p:=(yp-yl)/(xp-xl);
  xs:=round((xp-xl)/2)+xl;
  ys:=round((yp-yl)/2)+yl-1;
  textbackground(color);
  for i:=1 to round((xp-xl)/2) do begin
   owindow(xs-i,ys-round(i*p-0.6),xs+i,ys+round(i*p));
   clrscr;
   kurzorzap(false);
   delay(8);
   end;
  owindow(1,1,80,24);
  for i:=xl to xp do begin
   gotoxy(i,yl);write('Í');end;
  gotoxy(xp,yl);write('ť');
  for i:=yl+1 to yp do begin
   gotoxy(xp,i);write('ş');end;
  gotoxy(xp,yp);write('ź');
  for i:=xp-1 downto xl do begin
   gotoxy(i,yp);write('Í');end;
  gotoxy(xl,yp);write('Č');
  for i:=yp-1 downto yl do begin
   gotoxy(xl,i);write('ş');end;
  gotoxy(xl,yl);write('É');
  gotoxy(xs-(length(text) div 2),yl);write(' ',text,' ');
  owindow(xl+1,yl+1,xp-1,yp-1);
end;
 
procedure vezmi(x1,y1,x2,y2:integer);
var i,y:integer;
    reg:registers;
begin
 owindow(1,1,80,25);
 for i:=x1 to x2 do
  for y:=y1 to y2 do begin
   gotoxy(i,y);
   reg.ah:=8;
   reg.bh:=0;
   intr($10,reg);
   strana[1,i,y]:=reg.ah;
   strana[2,i,y]:=reg.al;
   end;
end;
 
procedure poloz(x1,y1,x2,y2:integer);
var i,y:integer;
    reg:registers;
begin
 owindow(1,1,80,25);
 for i:=x1 to x2 do
  for y:=y1 to y2 do begin
   gotoxy(i,y);
   reg.ah:=$9;
   reg.bh:=0;
   reg.al:=strana[2,i,y];
   reg.bl:=strana[1,i,y];
   reg.cx:=1;
   intr($10,reg);
   end;
end;
 
procedure koniec(naz_prog,rok:string);
begin
 farba(BLACK,-1);
 clrscr;
 farba(BLUE,YELLOW);
 writeln;
 writeln(copy(naz_prog+'               ',1,15)+
         ' Software by TRSEK. All right reserved, copyright TRSEK (c) '+rok+'.');
end;
 
function get_znak(x,y:byte;var farba:byte):byte;
var reg:registers;
    xo,yo:integer;
begin
 xo:=wherex;yo:=wherey;
 gotoxy(x,y);
 reg.ah:=8;
 reg.bh:=0;
 intr($10,reg);
 get_znak:=reg.al;
 farba:=reg.ah;
 gotoxy(xo,yo);
end;
 
procedure put_znak(x,y,farba,znak:byte);
var reg:registers;
    xo,yo:integer;
begin
 xo:=wherex;yo:=wherey;
 gotoxy(x,y);
 reg.ah:=$9;
 reg.bh:=0;
 reg.al:=znak;
 reg.bl:=farba;
 reg.cx:=1;
 intr($10,reg);
 gotoxy(xo,yo);
end;
 
procedure clear_keyb;
var Reg:Registers;
begin
 Reg.AX:=$C06;
 Reg.DL:=$FF;
 intr($21,Reg);
end;
 
end.