Program for make sound (beeper) in your program.

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Category: Source in Pascal
sounder.pngProgram: Sounder.pas
File exe: Sounder.exe
need: Trsek.pas
Example: Chaos.sndClassic.sndDlhy.sndMore.sndStupnica.snd

This program was created to meet the demands of music production using a special device called beeper. It is actually the editor which allows to lay the notes on the visual basis, to repeat playing of the music product and to store it finally in the file. The output is then used in your own program. It features a perfect design and mouse manipulation.

The program can hardly be reproached for any imperfections. I must not forget to mention the original author of this program - Tibor Kulcar. I made a couple of changes and checked on some of the faults which emerged from time to time.
{ TRSEK.PAS                 Copyright (c) TrSek alias Zdeno Sekerak }
{ Kniznica pouzivana skoro vsetkymi programami.                     }
{ Program POUZI.PAS demonstruje vsetky jej funkcie a procedury.     }
{                                                                   }
{ Datum:24.10.1995                             http://www.trsek.com }
 
unit TRSEK;
interface
 
type win_poin = record                  { Kvoli oknam }
      zani : pointer;
      poradie : byte;
      xova  : byte;
      yova  : byte;
      x_vel : byte;
      y_vel : byte;
      old_x1 : byte;
      old_y1 : byte;
      old_x2 : byte;
      old_y2 : byte;
      znaky : pointer;
      farby : pointer;
     end;
 
type byte_poin = record                 { Kvoli oknam }
      byt:array[1..2000] of byte;
     end;
 
var   ctrsek_b,ctrsek_f:byte;
      tdel:integer;                               { Pauza pri vytvarani okna}
      MinWin,MaxWin:integer;
      pom,win_pointer,wfirst_pointer:^win_poin;   { Smerniky na okna }
      win_pocet:byte;                           { Udrzuje pocet okien }
 
 procedure KurzorZap(ZapVyp:boolean);
 procedure farba(x,y:integer);
 procedure set_insert(ins:boolean);
 function  ctrl_akt:boolean;
 function  alt_akt:boolean;
 function  nothing(i:integer):string;
 function  zarovnaj(text:string;i:integer):string;
 procedure save_win;
 procedure old_win;
 procedure writexy(x,y:integer;s:string);
 {function  tread(x,y:integer; d:byte; text:string; sedy,pret:char):string;}
 function  tread(x,y:integer; d:byte; text:string; sedy: char; var pret:char):string;
 procedure open_win(xl,yl,xp,yp:integer;text:string;ramt:byte);
 function  otazka(x,y:integer;s1,s2,s3:string;color:byte;typ:byte):integer;
 procedure koniec(naz_prog,rok:string);
 procedure clear_keyb;
 function  get_znak(x,y:byte;var farba:byte):byte;
 procedure put_znak(x,y,farba,znak:byte);
 procedure zarad_okno (var win_pointer:win_poin;x1,y1,x2,y2:byte);
 function  get_window(x1,y1,x2,y2:integer):integer;
 function  put_window(por:integer;xn1,yn1,xn2,yn2:integer):integer;
 function  vyrad_okno (por:integer):integer;
 procedure rem_all_win;
 function  treadkey:char;
 procedure priklad;
 procedure help(str:char);
 
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<>-1 then begin textbackground(x);ctrsek_b:=x;end;
 if y<>-1 then begin textcolor(y);ctrsek_f:=y;end;
end;
 
procedure set_insert(ins:boolean);
var Reg:registers;
begin
 Reg.AH:=$01;
 Reg.CL:=$1E;
 if ins then Reg.CH:=$1D
        else Reg.CH:=$01;
 Intr($10,Reg);
end;
 
function ctrl_akt:boolean;
begin
 if (mem[0:$417] and 4) > 0 then ctrl_akt:=true
                            else ctrl_akt:=false;
end;
 
function alt_akt:boolean;
begin
 if (mem[0:$417] and 8) > 0 then alt_akt:=true
                            else alt_akt:=false;
end;
 
function nothing(i:integer):string;
const prazdny='                                                                                ';
begin
 nothing:=copy(prazdny,1,i);
end;
 
function zarovnaj(text:string;i:integer):string;
begin
 zarovnaj:=copy(text+nothing(i-length(text)),1,i);
end;
 
procedure save_win;
begin
 MinWin:=WindMin;MaxWin:=WindMax;
end;
 
procedure old_win;
begin
 window(Lo(MinWin)+1,Hi(MinWin)+1,Lo(MaxWin)+1,Hi(MaxWin)+1);
end;
 
procedure writexy(x,y:integer;s:string);
begin
 gotoxy(x,y);
 write(s);
end;
 
function tread(x,y:integer; d:byte; text:string; sedy: char; var pret:char):string;
 
var xp :integer;                                    { Pozicia kurzora }
    kl :char;
    ins:boolean;
    von:boolean;
    pis:boolean;
    fir:boolean;
    old_text:string;
 
begin
   farba(ctrsek_b,ctrsek_f);kurzorZap(true);
   ins:=true;set_insert(ins);
   kurzorZap(false);
   text:=zarovnaj(text,d);                          { Priprava !!! }
   if (x<1)       then x:=1;
   if (y<1)       then y:=1;
   if (x+d > Lo(WindMax)+1 ) then x:=Hi(WindMax)+1-d;
   if (y > Hi(WindMax)+1 )  then y:=Hi(WindMax)+1;
 
   xp:=1;x:=x-1;von:=false;pis:=true;fir:=true;
   if sedy<>#0 then sedy:=pret;old_text:=text;
 
   repeat
    if pis then begin
        KurzorZap(false);
        WriteXY(x+1,y,text);
        pis:=false;
       end;
    KurzorZap(true);
    gotoxy(x+xp,y);
 
    if fir then kl:=sedy
           else kl:=ReadKey;
 
    if ( kl=#0 ) then begin
       if fir then kl:=pret
              else kl:=ReadKey;
       case kl of
        #77:begin                                   { sipka vpravo }
             xp:=xp+1;
             if (xp>d) then xp:=d;
            end;
        #75:begin                                   { sipka vlavo  }
             xp:=xp-1;
             if (xp<1) then xp:=1;
            end;
        #83:begin                                   { DEL          }
             delete(text,xp,1);
             text:=text+' ';
             pis:=true;
            end;
        #80:von:=true;                              { sipka dole   }
        #72:von:=true;                              { sipka hore   }
        #59:begin                                   { F1-vrat text }
             text:=old_text;
             pis:=true;
             von:=true;
            end;
        #82:begin                                   { Insert       }
             ins:=not(ins);
             set_insert(ins);
            end;
        #71:xp:=1;                                  { HOME         }
        #79:begin                                   { End          }
             xp:=d;
             while ((xp>1) and (text[xp-1]=' ')) do
                   dec(xp);
            end;
        end;                                        { od CASE      }
       end                                          { od IF kl=#0  }
      else begin
       case kl of
        #27:von:=true;
        #13:von:=true;
        #08:if (xp>1) then begin
                delete(text,xp-1,1);text:=zarovnaj(text,d);
                pis:=true;dec(xp);
               end;
       else begin                                   { ELSE ku CASE    }
        if ins then begin
                insert(kl,text,xp);
                text:=zarovnaj(text,d);
               end
              else text[xp]:=kl;
        pis:=true;inc(xp);
        if (xp>d) then von:=true;
        end;                                        { end od begin pri ELSE ku CASE }
       end;                                         { od druheho CASE }
      end;                                          { od ELSE         }
   if fir then begin
                von:=false;
                fir:=false;
               end;
  until (von);
 
  pret:=kl;
  if (kl=#27) then tread:=old_text
              else tread:=text;
end;
 
procedure open_win(xl,yl,xp,yp:integer;text:string;ramt:byte);
const typr:array[1..4,1..6] of char=
           (('Í','ť','ş','ź','Č','É'),
            ('Ä','ˇ','ş','˝','Ó','Ö'),
            ('Í','¸','ł','ž','Ô','Ő'),
            ('Ä','ż','ł','Ů','Ŕ','Ú'));
var i,xs,ys:integer;
    p:real;
begin
  xs:=(xp-xl) div 2;
  ys:=(yp-yl) div 2;
  KurzorZap(false);
 
  if (xs>ys) then begin
     for i:=1 to xs-ys do begin
         Window(xl+xs-i,yl+ys,xl+xs+i,yl+ys);
         delay(tdel);
         clrscr;
        end;
 
     for i:=xs-ys to xs do begin
         Window(xl+xs-i,yl+xs-i,xl+xs+i,yl+2*ys-xs+i);
         delay(tdel);
         clrscr;
        end;
    end
   else begin
     for i:=1 to ys-xs do begin
         Window(xl+xs,yl+ys-i,xl+xs,yl+ys+i);
         delay(tdel);
         clrscr;
        end;
 
     for i:=ys-xs to ys do begin
         Window(xl+ys-i,yl+ys-i,xl+2*xs-ys+i,yl+ys+i);
         delay(tdel);
         clrscr;
        end;
    end;
 
  Window(xl,yl,xp,yp);
  clrscr;
  Window(1,1,80,25);
  for i:=xl to xp       do WriteXY(i,yl,typr[ramt,1]);
   WriteXY(xp,yl,typr[ramt,2]);
 
  for i:=yl+1 to yp     do WriteXY(xp,i,typr[ramt,3]);
   WriteXY(xp,yp,typr[ramt,4]);
 
  for i:=xp-1 downto xl do WriteXY(i,yp,typr[ramt,1]);
   WriteXY(xl,yp,typr[ramt,5]);
 
  for i:=yp-1 downto yl do WriteXY(xl,i,typr[ramt,3]);
   WriteXY(xl,yl,typr[ramt,6]);
 
  if text<>'' then WriteXY(xl+xs-(length(text) div 2),yl,' '+text+' ');
  Window(xl+1,yl+1,xp-1,yp-1);
end;
 
function otazka(x,y:integer;s1,s2,s3:string;color:byte;typ:byte):integer;
const otyp:array[0..3,1..2] of byte =
           ((26,27),(16,17),(62,60),(175,174));
var ch:char;
     s:array[1..3] of string;
    pk:array[1..2,0..2] of byte;     { Pozicia kurzora }
    i,odel:integer;
    otat,otap:byte;
begin
 { Urci typ uvodzoviek }
 otat:=(typ and 1)+(typ and 2);otap:=((typ and 4)+(typ and 8)) div 4;
 if (otap and 2)=2 then odel:=1
                   else odel:=5;
 
 { Z akych moznosti si ma vyberat a ich suradnice }
 s[1]:=s1;pk[2,0]:=0;pk[1,0]:=x;
 s[2]:=s2;pk[2,1]:=0;pk[1,1]:=x+length(s1)+odel;
 s[3]:=s3;pk[2,2]:=0;pk[1,2]:=x+length(s1)+length(s2)+2*odel;
 
 { Pre CRTL sekvenciu }
 for i:=length(s1) downto 1 do if UpCase(s1[i])=s1[i] then pk[2,0]:=ord(s1[i]);
 for i:=length(s2) downto 1 do if UpCase(s2[i])=s2[i] then pk[2,1]:=ord(s2[i]);
 for i:=length(s3) downto 1 do if UpCase(s3[i])=s3[i] then pk[2,2]:=ord(s3[i]);
 
 { Ma to byt spolu,a lebo ma mat rovnake medzery }
 if (otap and 1)=1 then begin
    i:=length(s1);
    if length(s2)>i then i:=length(s2);
    if length(s3)>i then i:=length(s3);
    pk[1,1]:=x+i+odel;
    pk[1,2]:=x+2*(i+odel);
   end;
 
 textbackground(ctrsek_b);
 WriteXY(pk[1,0],y,chr(otyp[otat,1])+s1+chr(otyp[otat,2]));
 if s2<>'' then WriteXY(pk[1,1],y,' '+s2+' ');
 if s3<>'' then WriteXY(pk[1,2],y,' '+s3+' ');
 i:=0;
 repeat
  textbackground(color);
  WriteXY(pk[1,i],y,chr(otyp[otat,1])+s[i+1]+chr(otyp[otat,2]));
  ch:=readkey;
 
  if ctrl_akt then begin                { Stlacil CRTL }
     textbackground(ctrsek_b);
     WriteXY(pk[1,i],y,' '+s[i+1]+' ');
     textbackground(color);
     if Ord(ch)+64 = pk[2,0] then begin i:=0;ch:=#13;end;
     if Ord(ch)+64 = pk[2,1] then begin i:=1;ch:=#13;end;
     if Ord(ch)+64 = pk[2,2] then begin i:=2;ch:=#13;end;
     if ch=#13 then
        WriteXY(pk[1,i],y,chr(otyp[otat,1])+s[i+1]+chr(otyp[otat,2]));
    end;
 
  if ch=#0 then begin
     ch:=readkey;
     if ch=#77 then begin                       { Pohyb sipkami }
        textbackground(ctrsek_b);WriteXY(pk[1,i],y,' '+s[i+1]+' ');
        i:=i+1;
        if s[i+1]='' then i:=i-1;
        if i>2 then i:=2;
       end;
     if ch=#75 then begin
        textbackground(ctrsek_b);WriteXY(pk[1,i],y,' '+s[i+1]+' ');
        i:=i-1;
        if i<0 then i:=0;
       end;
    end;
 
  if ch=#27 then begin otazka:=0;exit;end;
 until (ch in [#13]);                       { Koniec }
 otazka:=i+1;
end;
 
procedure koniec(naz_prog,rok:string);
begin
 farba(BLACK,-1);
 clrscr;
 farba(BLUE,YELLOW);
 writeln;
 writeln(zarovnaj(naz_prog,15)+
         ' Software by TRSEK. All right reserved, copyright TRSEK (c) '+rok+'.');
end;
 
procedure clear_keyb;
var Reg:Registers;
begin
 Reg.AX:=$C06;
 Reg.DL:=$FF;
 intr($21,Reg);
end;
 
function get_znak(x,y:byte;var farba:byte):byte;
var reg:registers;
    xo,yo:integer;
begin
 xo:=wherex;yo:=wherey;
 save_win;
 window(1,1,80,25);
 
 gotoxy(x,y);
 reg.ah:=8;
 reg.bh:=0;
 intr($10,reg);
 get_znak:=reg.al;
 farba:=reg.ah;
 old_win;
 gotoxy(xo,yo);
end;
 
procedure put_znak(x,y,farba,znak:byte);
var reg:registers;
    xo,yo:integer;
begin
 xo:=wherex;yo:=wherey;
 save_win;
 window(1,1,80,25);
 
 gotoxy(x,y);
 reg.ah:=$9;
 reg.bh:=0;
 reg.al:=znak;
 reg.bl:=farba;
 reg.cx:=1;
 intr($10,reg);
 old_win;
 gotoxy(xo,yo);
end;
 
procedure zarad_okno (var win_pointer:win_poin;x1,y1,x2,y2:byte);
begin
 inc(win_pocet);
 win_pointer.poradie:=win_pocet;             { Zapis poradie okna       }
 win_pointer.xova:=x1;                         { Lavy horny roh x-ovej    }
 win_pointer.yova:=y1;
 win_pointer.x_vel:=(x2-x1);                   { velkost okna             }
 win_pointer.y_vel:=(y2-y1);
 
 win_pointer.old_x1:=Lo(WindMin)+1;              { Lavy horny roh aktivneho }
 win_pointer.old_y1:=Hi(WindMin)+1;
 win_pointer.old_x2:=Lo(WindMax)+1;              { Pravy dolny roh aktivneho }
 win_pointer.old_y2:=Hi(WindMax)+1;
 
 win_pointer.zani:=NIL;
 if wfirst_pointer=NIL then begin
     wfirst_pointer:=@win_pointer;
    end
    else begin
     pom:=wfirst_pointer;
     while (pom^.zani<>NIL) do pom:=pom^.zani;
     pom^.zani:=pointer(@win_pointer);
    end;
end;
 
function get_window(x1,y1,x2,y2:integer):integer;
var x,y,i:integer;
    reg:registers;
    pom1,pom2:^byte_poin;
    velkost:word;
begin
 save_win;
 get_window:=0;
 { Ziskaj pamet     + 2b pred, 2b zani, 1b poradie okna }
 {                    1b celkova sirka, 1b celkova vyska }
 velkost:= SizeOf( Win_poin ) + 2*(x2-x1+1)*(y2-y1+1);
 if velkost>MaxAvail then begin
    write('Malo pamete, k dispozicii iba ',MaxAvail,' B konvencnej pamete.');
    exit;
   end;
 
 GetMem(win_pointer,SizeOf( Win_poin) );          { Rezervuj pamet  pre smernik }
 GetMem(win_pointer^.znaky,(x2-x1+1)*(y2-y1+1) ); { Rezervuj pamet  pre znaky   }
 GetMem(win_pointer^.farby,(x2-x1+1)*(y2-y1+1) ); { Rezervuj pamet  pre farby   }
 
 zarad_okno(win_pointer^,x1,y1,x2,y2);
 pom1:=win_pointer^.znaky;
 pom2:=win_pointer^.farby;
 
 window(1,1,80,25);
 i:=0;
 for x:=x1 to x2 do
  for y:=y1 to y2 do begin
   gotoxy(x,y);
   reg.ah:=8;
   reg.bh:=0;
   intr($10,reg);
   inc(i);
   pom1^.byt[i]:=reg.ah;
   pom2^.byt[i]:=reg.al;
   end;
 old_win;
 get_window:=win_pocet;
end;
 
function put_window(por:integer;xn1,yn1,xn2,yn2:integer):integer;
var x,y,i:integer;
    x1,x2,y1,y2:integer;
    reg:registers;
    pom1,pom2:^byte_poin;
begin
 win_pointer:=wfirst_pointer;
 while ( (win_pointer^.zani<>NIL) and (win_pointer^.poradie<>por) ) do
         win_pointer:=win_pointer^.zani;
 
 if win_pointer^.poradie<>por then begin
                  put_window:=1;
                  exit;
                 end;
 
 with win_pointer^ do begin
      x1:=xova;
      y1:=yova;
      x2:=x1+x_vel;
      y2:=y1+y_vel;
      pom1:=znaky;
      pom2:=farby;
     end;
 
 if xn1=0 then xn1:=x1;
 if yn1=0 then yn1:=y1;
 if xn2=0 then xn2:=80;
 if yn2=0 then yn2:=25;
 xn1:=xn1-x1;
 yn1:=yn1-y1;
 
 window(1,1,80,25);
 i:=0;
 for x:=x1 to x2 do
  for y:=y1 to y2 do begin
   gotoxy(x+xn1,y+yn1);
   reg.ah:=$9;
   reg.bh:=0;
   inc(i);
   reg.al:=pom2^.byt[i];
   reg.bl:=pom1^.byt[i];
   reg.cx:=1;
   if (y-y1<=yn2) and (x-x1<=xn2) then intr($10,reg);
   end;
 with win_pointer^ do window(old_x1,old_y1,old_x2,old_y2);
 put_window:=0;
end;
 
function vyrad_okno (por:integer):integer;
var velkost:word;
begin
 win_pointer:=wfirst_pointer;
 pom:=NIL;
 while ( (win_pointer^.zani<>NIL) and (win_pointer^.poradie<>por) ) do begin
         pom:=win_pointer;
         win_pointer:=win_pointer^.zani;
        end;
 
 if win_pointer^.poradie<>por then begin
                  vyrad_okno:=0;
                  exit;
                 end;
 
 with win_pointer^ do begin
      if (pom<>NIL) then pom^.zani:=win_pointer^.zani
                    else wfirst_pointer:=win_pointer^.zani;
      if (pom=NIL) and (win_pointer^.zani=NIL) then begin
          wfirst_pointer:=NIL;
          win_pocet:=0;
         end;
      velkost:=(x_vel+1)*(y_vel+1);
     end;
 
   FreeMem(win_pointer^.farby, velkost );      { Uvolni pamet  pre znaky   }
   FreeMem(win_pointer^.znaky, velkost );      { Uvolni pamet  pre znaky   }
   FreeMem(win_pointer,SizeOf( win_poin ) );   { Uvolni pamet  pre smernik }
 vyrad_okno:=por;
end;
 
procedure rem_all_win;
var i,err:integer;
begin
 for i:=win_pocet downto 1 do
     err:=vyrad_okno(i);
end;
 
function treadkey:char;
var ch,c:char;
begin
 repeat
  ch:=readkey;
  if ch=#0 then c:=readkey;
 until (ch in [#27,#13,#32,'A'..'z']);
 treadkey:=ch;
end;
 
procedure priklad;
begin
 writeln;
 writeln('Priklad:');
 writeln('--------');
end;
 
procedure help(str:char);
var ch:char;
    i:integer;
begin
 window(1,1,80,25);
 farba(BLACK,WHITE);
 clrscr;
 writeln('Vysvetlenie funkcii v tomto UNITE');
 writeln('---------------------------------');
 writeln;
 writeln('Autorom unitu je Zdeno Sekerak alias TRSEK');
 writeln('Adresa:  Zdeno Sekerak');
 writeln('         Trnkov 18');
 writeln('         p.Kapusany');
 writeln('         082 12 okr.Presov');
 writeln;
 writeln('Autor si vyhradzuje prava na predaj, alebo inu obchodnu cinnost');
 writeln('s tymto unitom. Je chapany ako FREEWARE.');
 writeln;
 writeln('V Presove 24.10.1995');
 writeln;
 writeln('Nabuduce: unit OBRAZ pre zobrazovanie a pracu s obrazkami TIF,BMP,PCX.');
 writeln('          unit ASCII pre narodnu znakovu podporu a definovanie klavesnice.');
 writeln;
 writeln('Stlac klaves pre akukolvek pracu.');
 ch:=treadkey;
 
 repeat
  writeln(' Zoznam prikazov:');
  writeln('------------------');
  writeln(' A- procedure KurzorZap (ZapVyp:boolean);                                     ');
  writeln(' B- procedure Farba (x,y:integer);                                            ');
  writeln(' C- procedure Insert_Kurzor (ins:boolean);                                    ');
  writeln(' D- function  Ctrl_Akt:boolean;                                               ');
  writeln(' E- function  Alt_Akt:boolean;                                                ');
  writeln(' F- function  Nothing (i:integer): string;                                    ');
  writeln(' G- function  Zarovnaj (text:string;i:integer): string;                       ');
  writeln(' H- procedure Save_Win;                                                       ');
  writeln(' I- procedure Old_Win;                                                        ');
  writeln(' J- procedure WriteXY (x,y:integer;s:string);                                 ');
  writeln(' K- function  Tread (x,y:integer; d:byte; text:string; sedy,pret:char): string;');
  writeln(' L- procedure Open_Win (xl,yl,xp,yp:integer;text:string;ramt:byte);           ');
  writeln(' M- function  Otazka (x,y:integer;s1,s2,s3:string;col:byte;typ:byte): integer;');
  writeln(' N- procedure Koniec (naz_prog,rok:string);                                   ');
  writeln(' O- procedure Clear_Keyb;                                                     ');
  writeln(' P- function  Get_Znak (x,y:byte;farba:byte): byte;                       ');
  writeln(' R- procedure Put_Znak (x,y,farba,znak:byte);                                 ');
  writeln(' S- procedure Zarad_Okno (win_pointer:win_poin;x1,y1,x2,y2:byte);         ');
  writeln(' T- function  Get_Window (x1,y1,x2,y2:integer): integer;                      ');
  writeln(' U- function  Put_Window (por:integer;xn1,yn1,xn2,yn2:integer): integer;      ');
  writeln(' V- function  Vyrad_Okno (por:integer): integer;                              ');
  writeln(' X- procedure Rem_All_Win;                                                    ');
  write('Stlac pismeno pre podrobny help (ESC-Koniec):');
 
  if str<>' ' then begin ch:=str;str:=' ';end
              else ch:=treadkey;
  clrscr;
 
  case Upcase(ch) of
    'A':begin
         writeln('procedure KurzorZap (ZapVyp:boolean);                                     ');
         writeln('-------------------------------------');
         writeln('Zapina/vypina zobrazenie kurzora na obrazovke');
         priklad;
         writeln('KurzorZap(False);');
         writeln('KurzorZap(True);');
        end;
    'B':begin
         writeln('procedure Farba (x,y:integer);                                            ');
         writeln('------------------------------');
         writeln('Nastavi farbu podkladu (prve cislo) a farbu pisma (druhe cislo).');
         writeln('Pricom ak zadate farbu o hodnote -1 necha aktualnu.');
         writeln('Simuluje prikazy TextBackGround + TextColor.');
         writeln('Farby takto nastavene pouzivaju ostatne prikazy UNITu pracujuce s obrazovkou.');
         writeln('Nastavuje vnutorne premenne CTRSEK_B farbou podkladu a');
         writeln('                            CTRSEK_F farbou pisma.');
         priklad;
         writeln('Farba(BLUE,YELLOW);');
        end;
    'C':begin
         writeln('procedure Insert_Kurzor (ins:boolean);                                    ');
         writeln('--------------------------------------');
         writeln('Zobrazi kurzor ako podciarnik, alebo plne okienko.');
         writeln('Pouzitie pre naznacenie uzivatelovi, ze vkladane udaje budu INSERT.');
         priklad;
         writeln('Insert_Kurzor(True);');
        end;
    'D':begin
         writeln('function  Ctrl_Akt:boolean;                                               ');
         writeln('---------------------------');
         writeln('Testuje aktivitu klavesi CTRL vo chvili ked bola funkcia zavolana.');
         writeln('Pozor nie predosle, ale aktualne.');
         priklad;
         writeln('If Crtl_Akt then WriteLn('+chr(39)+'Klaves CRTL aktivny.'+chr(39)+');');
        end;
    'E':begin
         writeln('function  Alt_Akt:boolean;                                                ');
         writeln('--------------------------');
         writeln('Testuje aktivitu klavesi ALT vo chvili ked bola funkcia zavolana.');
         writeln('Pozor nie predosle, ale aktualne.');
         priklad;
         writeln('If Alt_Akt then WriteLn('+chr(39)+'Klaves ALT aktivny.'+chr(39)+');');
        end;
    'F':begin
         writeln('function  Nothing (i:integer): string;                                    ');
         writeln('--------------------------------------');
         writeln('Funkcia vrati prazdny retazec o I medzerach.');
         writeln('Obcas chcete aby to bol zdrojak prehladny.');
         writeln('Niet nad taketo rutiny.');
         priklad;
         writeln('s:=Nothing(12);');
        end;
    'G':begin
         writeln('function  Zarovnaj (text:string;i:integer): string;                       ');
         writeln('---------------------------------------------------');
         writeln('Funkcia k retazcu prida tolko medzier, aby jeho dlzka bola i znakov.');
         priklad;
         writeln('Write( Zarovnaj('+chr(39)+'Text o 40 znakoch'+chr(39)+',40) );');
        end;
    'H':begin
         writeln('procedure Save_Win;                                                       ');
         writeln('-------------------');
         writeln('Ulozi si suradnice aktivneho okna do vnutornych premennych MinWin a WinMax.');
         writeln('Spatne ich pouzije pri obnoveny suradnic okna v procedure Old_Win.');
         writeln('Pozor nepameta si jeho obsah nato je Get_Win.');
         priklad;
         writeln('Save_Win;');
         writeln('Window(1,1,80,25);');
         writeln('ClrScr;');
         writeln('Old_Win');
        end;
    'I':begin
         writeln('procedure Old_Win;                                                        ');
         writeln('------------------');
         writeln('Obnovi suradnice okna, ktore nastavil Save_win.');
         writeln('Pozor nenakresli jeho obsah nato je Put_Win.');
         priklad;
         writeln('Save_Win;');
         writeln('Window(1,1,80,25);');
         writeln('ClrScr;');
         writeln('Old_Win');
        end;
    'J':begin
         writeln('procedure WriteXY (x,y:integer;s:string);                                 ');
         writeln('-----------------------------------------');
         writeln('Vypise text S na X,Y poziciu na obrazovke.');
         writeln('Kumulovane prikazy GotoXY a Write.');
         priklad;
         writeln('WriteXY (2,3,'+chr(39)+'Text na 2stlpci 3riadku'+chr(39)+');');
        end;
    'K':begin
         writeln('function  Tread (x,y:integer; d:byte; text:string; sedy,pret:char): string;');
         writeln('---------------------------------------------------------------------------');
         writeln('Read v okienku s editaciou a funkcnymi sipkami, INS, DEL, BACKSPACE, ECS.');
         writeln('x,y - suradnice, kde citat');
         writeln('d   - dlzka textu aky sa ma nacitat (pohybovat)');
         writeln('text- aky text ma poskytnut na editaciu');
         writeln('sedy- ak je #0 znamena PRET je seda klavesa');
         writeln('      pred vlastnou editaciu vykona pohyb klavesy.');
         writeln('      Inac sedy znamena obycajny klaves.');
         writeln;
         writeln('Vrati naeditovany text.');
         writeln('Uznava farby nastavene procedurou Farba.');
         priklad;
         writeln('Farba(Blue,Yellow);');
         writeln('WriteXY(10,12,'+chr(39)+'Zadaj meno:'+chr(39)+');');
         writeln('meno:=Tread(21,12,30,'+chr(39)+'BezMena'+chr(39)+',#0,#0);');
        end;
    'L':begin
         writeln('procedure Open_Win (xl,yl,xp,yp:integer;text:string;ramt:byte);           ');
         writeln('---------------------------------------------------------------');
         writeln('Efektne otvorenie okna s poziciu.');
         writeln('xl,yl - lavy horny roh');
         writeln('xp,yp - pravy dolny roh');
         writeln('text  - nadpis okna');
         writeln('ramt  - typ ramceka 1..4');
         writeln('Uznava farby nastavene procedurou Farba.');
         writeln('Vnutornou premennou TDEL sa da nastavit rychlost otvarania');
         writeln('okien.');
         priklad;
         writeln('tdel:=30;');
         writeln('Farba(Blue,Yellow);');
         writeln('open_win(60,7,80,11,'+chr(39)+'Okno 1'+chr(39)+',1);');
         writeln('Farba(Green,Red);');
         writeln('open_win(60,12,80,15,'+chr(39)+'Okno 2'+chr(39)+',2);');
         writeln('Farba(Red,LightGray);');
         writeln('open_win(60,16,80,19,'+chr(39)+'Okno 3'+chr(39)+',3);');
         writeln('Farba(Blue,Yellow);');
         writeln('open_win(60,20,80,23,'+chr(39)+'Okno 4'+chr(39)+',4);');
 
         farba(blue,yellow);
         open_win(60,7,80,11,'Okno 1',1);
         farba(Green,Red);
         open_win(60,12,80,15,'Okno 2',2);
         farba(Red,LightGray);
         open_win(60,16,80,19,'Okno 3',3);
         farba(blue,yellow);
         open_win(60,20,80,23,'Okno 4',4);
         window(1,1,80,25);
         farba(Black,White);gotoxy(1,23);
        end;
    'M':begin
         repeat
         writeln('function  Otazka (x,y:integer;s1,s2,s3:string;col:byte;typ:byte): integer;');
         writeln('--------------------------------------------------------------------------');
         writeln('Polozenie otazky uzivatelovi.');
         writeln('x,y      - pozicia otazok na obrazovke.');
         writeln('s1,s2,s3 - Tri moznosti, pricom ak sa jedna vynecha budu 2, atd.');
         writeln('Farba aktualnej odpovede.');
         writeln('typ      - typ bity 1,2 urcuju aka ma mat uvodzovky');
         writeln('                    3   ci ma byt byt zhusteny tvar, alebo rovnaky rozostup.');
         writeln('           uvodzovky typ 2, nezhusteny tvar typ 1 potom typ:=2+1*4;');
         writeln('Prve velke pismeno urcuje moznost stlacit CRTL+to pismeno.');
         writeln('Uznava farby nastavene vo Farba.');
         writeln;
         writeln('Odpoved je 0=ESC, alebo poradove cislo odpovede.');
         priklad;
         writeln('Farba(Blue,Yellow);');
         writeln('WriteXY(45,15,'+chr(39)+'Pokracovat ???'+chr(39)+');');
         writeln('odpoved:=Otazka(40,17,'+chr(39)+'Ano'+chr(39)+','+chr(39)+'Nie'+chr(39)+
                                        ','+chr(39)+'osTan'+chr(39)+',Green,5);');
         Farba(Blue,Yellow);
         WriteXY(45,15,'Pokracovat ???');
         i:=Otazka(40,17,'Ano','Nie','osTan',Green,5);
         delay(500);
         Window(1,1,80,25);
         farba(Black,White);gotoxy(1,23);clrscr;
         until (i in [0,1]);
        end;
    'N':begin
         writeln('procedure Koniec (naz_prog,rok:string);                                   ');
         writeln('---------------------------------------');
         writeln('Vypise efektne ako NC Software by atd. s nazvom NAZ_PROG');
         writeln('a rokom vyrobi ROK.');
         writeln('Pre pouzitie autora.');
         priklad;
         writeln('Koniec('+chr(39)+'Super UNIT'+chr(39)+','+chr(39)+'95'+chr(39)+');');
        end;
    'O':begin
         writeln('procedure Clear_Keyb;                                                     ');
         writeln('---------------------');
         writeln('Zmaze buffer klavesnice, ak je naplneny znakmi.');
         writeln('Moze sa stat, ze chcete, aby pred neakou otazkou na');
         writeln('uziavtela bol buffer prazdny pouzite Clear_Keyb;');
         priklad;
         writeln('Farba(Blue,Yellow);');
         writeln('WriteXY(45,15,'+chr(39)+'Pokracovat ???'+chr(39)+');');
         writeln('Clear_Keyb');
         writeln('odpoved:=Otazka(40,17,'+chr(39)+'Ano'+chr(39)+','+chr(39)+'Nie'+chr(39)+
                                        ','+chr(39)+'osTan'+chr(39)+',Green,5);');
        end;
    'P':begin
         writeln('function  Get_Znak (x,y:byte;farba:byte): byte;                       ');
         writeln('---------------------------------------------------');
         writeln('Vrati znak, ktory je na pozicii x,y.');
         writeln('Jeho farbu v premennej farba.');
         writeln('Farba- dolne 4 bity su podklad, horne 4 pismo.');
         writeln('farba_pisma:=(Color div 16)/16; farba_podkladu:=Color mod 16;');
         writeln('Pozor farba nemoze byt cislo, musi byt premenna.');
         priklad;
         writeln('znak:=Get_Znak(10,10,Color);');
        end;
    'R':begin
         writeln('procedure Put_Znak (x,y,farba,znak:byte);                                 ');
         writeln('-----------------------------------------');
         writeln('Inverzna procedure k Get_Znak.');
         writeln('x,y je pozicia');
         writeln('farba je farba znaku+podklad       farba:=Blue*16+Yellow');
         writeln('znak je Ord(znaku), ktory ma byt vypisovany.');
         priklad;
         writeln('Put_znak(70,10,Blue*16+Yellow,Ord('+chr(39)+'a'+chr(39)+'));');
         Put_znak(70,10,Blue*16+Yellow,Ord('a'));
        end;
    'S':begin
         writeln('procedure Zarad_Okno (win_pointer:win_poin;x1,y1,x2,y2:byte);         ');
         writeln('-------------------------------------------------------------');
         writeln('Vyhradi miesto v pameti pre okno s Win_Pointer pre suradnice');
         writeln('x1,y1,x2,y2.');
         writeln('Tuto rutinku pouziva Get_Window.');
        end;
    'T':begin
         writeln('function  Get_Window (x1,y1,x2,y2:integer): integer;                      ');
         writeln('----------------------------------------------------');
         writeln('Zapamata si aktivne okno a jeho obsah a ulozi do pamate.');
         writeln('Rozmeri okna su lavy -horny (x1,y1)');
         writeln('                pravy-dolny (x2,y2)');
         writeln;
         writeln('Vrati identifikacne cislo (ICO) ake bolo oknu pridelene.');
         writeln('Celkovy pocet okien je vo vnutornej premennej WIN_POCET.');
         writeln;
         writeln('Vo vnutornej premennej WIN_POCET je pocet okien ulozenych v pamati.');
         priklad;
         writeln('Farba(Blue,Yellow);');
         writeln('open_win(60,7,80,11,'+chr(39)+'Okno 1'+chr(39)+',1);');
         writeln('okno:=Get_Window(10,2,70,20);');
         writeln('Key:=ReadKey;');
         writeln('ClrScr;');
         writeln('err:=Put_Window(okno,0,0,0,0);');
         farba(Blue,Yellow);
         open_win(60,7,80,11,'Okno 1',1);
         i:=Get_Window(10,2,70,20);
         window(1,1,80,25);farba(Black,White);
         ch:=tReadKey;
         ClrScr;
         i:=Put_Window(i,0,0,0,0);
         ch:=tReadKey;ch:=#13;
         window(1,1,80,25);farba(Black,White);
         gotoxy(1,23);
        end;
    'U':begin
         writeln('function  Put_Window (por:integer;xn1,yn1,xn2,yn2:integer): integer;      ');
         writeln('-----------------------------------------------------------');
         writeln('Inverzna k Get_Window.');
         writeln('Por - ake okno v roradi vykreslit.');
         writeln('xn1,yn1 - su nove suradnice do laveho horneho rohu do ktoreho ma vykreslit.');
         writeln('xn2,yn2 - je velkost aku ma zobrazit z osi x,y.');
         writeln('0,0,0,0 - znamena v povodnych suradniciach.');
         writeln;
         writeln('Vrati hodnoty 1-nenasiel som take okno');
         writeln('              0-vykreslil som toto okno');
         writeln;
         writeln('Vo vnutornej premennej WIN_POCET je pocet okien ulozenych v pamati.');
         priklad;
         writeln('Farba(Blue,Yellow);');
         writeln('open_win(60,7,80,11,'+chr(39)+'Okno 1'+chr(39)+',1);');
         writeln('okno:=Get_Window(10,2,70,20);');
         writeln('Key:=ReadKey;');
         writeln('ClrScr;');
         writeln('err:=Put_Window(okno,1,1,60,10);');
         farba(Blue,Yellow);
         open_win(60,7,80,11,'Okno 1',1);
         i:=Get_Window(10,2,70,20);
         window(1,1,80,25);farba(Black,White);
         ch:=tReadKey;
         ClrScr;
         i:=Put_Window(i,1,1,60,10);
         ch:=tReadKey;ch:=#13;
         window(1,1,80,25);farba(Black,White);
         gotoxy(1,23);
 
        end;
    'V':begin
         writeln('function  Vyrad_Okno (por:integer): integer;                              ');
         writeln('--------------------------------------------');
         writeln('Vyhodi okno s pamate s poradovim cislom POR.');
         writeln('Pozor predtym nez ho vyhodi nevykresli ho.');
         writeln('Preto, ak chcete vydiet okno dajte ho najprv vykreslit,');
         writeln('az tak vyhodit s pamete.');
         writeln('Autor odporuca vyhadzovat v opacnomn poradi ako boli zaradene,');
         writeln('pretoze pamet sa uvolni az po VYRADeni posledneho okna.');
         writeln;
         writeln('Ak vrati hodnotu 0-znamena, ze uz bolo vyradene, alebo sa neda vyhodit.');
         writeln('               <>0-uspesne vyradene toto okno');
         writeln;
         writeln('Vo vnutornej premennej WIN_POCET je pocet okien ulozenych v pamati.');
         priklad;
         writeln('err:=Vyrad_Okno(1);');
        end;
    'X':begin
         writeln('procedure Rem_All_Win;                                                    ');
         writeln('----------------------');
         writeln('Procedura vyhodi vsetky okna s pamate a uvolni ju.');
        end;
  end;
 
  if ch<>#27 then begin
      writeln;
      writeln('Koniec ESC.  Spat stlac akukolvek klavesu.');
      ch:=treadkey;
      if ch=#27 then ch:=#13;
     end;
 until (ch=#27);
end;
 
begin
 writeln;
 writeln('Tento program pouziva UNIT od TRSEKa         Prikaz help('+chr(39)+' '+chr(39)+'); pre pomoc');
 writeln('adresa  WORD:\Europe\Slovakia\Presov\Trnkov_18\Zdeno_Sekerak.programator');
 delay(500);
 ctrsek_b:=BLACK;
 ctrsek_f:=WHITE;
 save_win;
 tdel:=30;
 wfirst_pointer:=NIL;
 win_pocet:=0;
end.