{ KNIZNIC.PAS               Copyright (c) TrSek alias Zdeno Sekerak }
{ Rutiny pre jednoduchsiu pracu s oknami a retazcami.               }
{                                                                   }
{ Datum:19.06.1995                            http://www.trsek.com  }
 
unit kniznic;
interface
uses dos,crt;
 
const map_mes:array[1..12] of integer =
              (0,31,59,90,120,151,181,212,243,273,304,334);
 
var xw1,yw1,xw2,yw2:integer;
    z_sound:boolean;            { zapnuty/vypnuty zvuk pre hlasku }
 
procedure twindow(x1,y1,x2,y2:integer);
procedure owindow(x1,y1,x2,y2:integer);
procedure okno(x1, y1, x2, y2:integer; text,podpis:string; bar:integer);
procedure vypln(s:string);
procedure hlaska(s:string;del:integer);
function vali(s:string):longint;
function valr(s:string):real;
function stri(i:longint;k:integer):string;
function strr(i:real;k:integer):string;
function strri(i:real;k:integer;p:integer):string;
function strs(s:string;medzera:boolean):string;
function strsi(s:string;p:integer):string;
function nothing(i:integer):string;
procedure prikaz(s:string);
function ask_date(s:string):string;
function poc_dni(s:string):LongInt;
function get_date(pp:LongInt):string;
function get_realy_date(typ:integer):string;
function s_exist(s:string;velk:integer):boolean;
procedure z_hlava(var strana,poc_y:integer;var f:text;aky_text:string);
 
implementation
 
procedure twindow(x1,y1,x2,y2:integer);
begin
 window(x1,y1,x2,y2);
end;
 
procedure owindow(x1,y1,x2,y2:integer);
begin
 twindow(x1,y1,x2,y2);
 xw1:=x1;yw1:=y1;xw2:=x2;yw2:=y2;
end;
 
procedure okno(x1, y1, x2, y2:integer; text,podpis:string; bar:integer);
var x,y:integer;
begin
 owindow(x1+1,y1+1,x2-1,y2-1);
 textbackground(bar);
 clrscr;
 owindow(1,1,80,25);
 
 for x:=x1+1 to x2-1 do begin
     gotoxy(x,y1);write('Ä');
     gotoxy(x,y2);write('Ä');
     end;
 
 for y:=y1+1 to y2-1 do begin
     gotoxy(x1,y);write('ł');
     gotoxy(x2,y);write('ł');
     end;
 
 gotoxy(x1,y1);write('Ú');
 gotoxy(x2,y1);write('ż');
 gotoxy(x1,y2);write('Ŕ');
 gotoxy(x2,y2);write('Ů');
 textbackground(bar);
 gotoxy(x1+round((x2-x1-length(text))/2),y1);write(text);
 gotoxy(x2-length(podpis)-2,y2);write(podpis);
 owindow(x1+1,y1+1,x2-1,y2-1);
end;
 
procedure vypln(s:string);
var i:integer;
begin
 owindow(xw1+3,yw1+1,xw2-3,yw2-1);
 textbackground(BLUE);textcolor(LIGHTGRAY);
 gotoxy(1,1);
 for i:=1 to round(((xw2-xw1)*(yw2-yw1+2)+18)/length(s)) do write(s);
 textcolor(YELLOW);
end;
 
procedure hlaska(s:string;del:integer);
var i:integer;
    odloz:array[1..2,1..80] of byte;
    reg:registers;
    xo1,yo1,xo2,yo2:integer;
begin
 xo1:=xw1;yo1:=yw1;xo2:=xw2;yo2:=yw2;
 owindow(1,1,80,25);
 textbackground(DARKGRAY);
 for i:=1 to length(s) do begin
   gotoxy(xw1+i,25);
   reg.ah:=8;
   reg.bh:=0;
   intr($10,reg);
   odloz[1,i]:=reg.ah;
   odloz[2,i]:=reg.al;
   end;
 gotoxy(xw1+1,25);
 if del=-2 then write(nothing(78))
           else write(s);
 if z_sound then begin sound(500);delay(3);nosound;end;
 if del=-1 then begin
    owindow(xo1,yo1,xo2,yo2);
    exit;
    end;
 
 if del=0 then repeat until keypressed
          else delay(abs(del)*10);
 
 for i:=1 to length(s) do begin
   gotoxy(xw1+i,25);
   reg.ah:=$9;
   reg.bh:=0;
   reg.al:=odloz[2,i];
   reg.bl:=odloz[1,i];
   reg.cx:=1;
   intr($10,reg);
   end;
 owindow(xo1,yo1,xo2,yo2);
end;
 
function vali(s:string):longint;
var vys:longint;
    err:integer;
begin
 if length(s)<2 then s:='0'+s;                          { Len aby !!! }
 while (pos(' ',s)>0) do delete(s,pos(' ',s),1);
 val(s,vys,err);
 while ( (err<>0) and (s<>'') ) do begin
       delete(s,err,1);
       val(s,vys,err);
       end;
 vali:=vys;
end;
 
function valr(s:string):real;
var err:integer;
    vys:real;
begin
 while (pos(' ',s)>0) do delete(s,pos(' ',s),1);
 val(s,vys,err);
 while ( (err<>0) and (s<>'') )do begin
       delete(s,err,1);
       val(s,vys,err);
       end;
 valr:=vys;
end;
 
function stri(i:longint;k:integer):string;
var s:string;
begin
 str(i:k,s);
 stri:=s;
end;
 
function strr(i:real;k:integer):string;
var s:string;
begin
 str(i:k:2,s);
 strr:=s;
end;
 
function strri(i:real;k:integer;p:integer):string;
var s:string;
begin
 str(i:k:p,s);
 strri:=s;
end;
 
function strs(s:string;medzera:boolean):string;
var i:integer;
    sp:string;
begin
 sp:='';i:=1;
 if medzera then
    while ( (s[i] in [' '..'z']) and (i<=length(s)) ) do
      begin
       sp:=sp+s[i];
       i:=i+1;
      end
   else
    while ( (s[i] in ['!'..'z']) and (i<=length(s)) ) do
      begin
       sp:=sp+s[i];
       i:=i+1;
      end;
 
 strs:=sp;
end;
 
function strsi(s:string;p:integer):string;
var i:integer;
    sp:string;
begin
 sp:='';i:=1;
 while ( (s[i] in [' '..'ţ']) and (i<=length(s)) ) do
  begin
   sp:=sp+s[i];
   i:=i+1;
  end;
 while ( (pos(' ',sp)>0) and (length(sp)>0) ) do delete(sp,pos(' ',sp),1);
 strsi:=nothing(p-length(sp))+copy(sp,1,p);
end;
 
function nothing(i:integer):string;
begin
 nothing:=copy('                                                                                ',1,i);
end;
 
procedure prikaz(s:string);
begin
  SwapVectors;
  Exec(GetEnv('COMSPEC'), '/C '+s);
  SwapVectors;
  if doserror<>0 then hlaska(' Chyba '+stri(doserror,0)+' ',0);
end;
 
function ask_date(s:string):string;
begin
 ask_date:=s[7]+s[8]+'.'+s[5]+s[6]+'.'+copy(s,1,4);
end;
 
function poc_dni(s:string):LongInt;
var p:LongInt;
    r,m,d:integer;
begin
 r:=vali(copy(s,1,4));m:=vali(s[5]+s[6]);d:=vali(s[7]+s[8]);
 poc_dni:=LongInt(r)*365+map_mes[m]+d;
end;
 
function get_date(pp:LongInt):string;
var r,m,d:integer;
        i:integer;
        s:string;
begin
 r:=trunc(pp/365);
 d:=pp-r*365;
 i:=1; while ( (map_mes[i]<=d) and (i<=12) ) do i:=i+1;
 m:=i-1;
 d:=d-map_mes[m]+1;
 s:=stri(r,4);
 if m<10 then s:=s+'0'+stri(m,1)
         else s:=s+stri(m,2);
 
 if d<10 then s:=s+'0'+stri(d,1)
         else s:=s+stri(d,2);
 
 get_date:=s;
end;
 
function get_realy_date(typ:integer):string;
const
  days : array [0..6] of String[8] =
    ('Nede-a','Pondelok','Utorok',
     'Streda','ćtvrtok','Piatok','Sobota');
var
  y, m, d, dow : Word;
  s,c:string;
begin
  GetDate(y,m,d,dow);
  if typ=1 then
     get_realy_date:= days[dow]+'  '+stri(d,0)+ '/'+ stri(m,0)+ '/'+ stri(y,0)
    else
     begin
      c:= copy(stri(y,4),3,2);
      s:= stri(m,0); if length(s)<2 then s:='0'+s;
      c:=c+s;
      s:= stri(d,0); if length(s)<2 then s:='0'+s;
      c:=c+s;
      get_realy_date:=c;
     end;
end;
 
function s_exist(s:string;velk:integer):boolean;
var s_find:SearchRec;
begin
 FindFirst(s,Archive,s_find);
 if velk=1 then begin
    if (DosError=0) and (s_find.size<>0) then s_exist:=true
                                         else s_exist:=false;
    end
   else begin
    if (DosError=0) then s_exist:=true
                    else s_exist:=false;
    end
end;
 
procedure z_hlava(var strana,poc_y:integer;var f:text;aky_text:string);
var err:integer;
begin
 append(f);
 err:=ioresult;
 {$I+}
 if err<>0 then begin hlaska('Chyba z pisu na disk. Pracovně disk chr neně proti z pisu.',0);exit;end;
 if strana<>0 then writeln(f,chr(12));
 poc_y:=2;inc(strana);
 writeln(f,aky_text+' Zo dĺa '+get_realy_date(1)+'           strana:'+stri(strana,0));
 writeln(f,'');
end;
 
 
end.