{ SOUNDER.PAS Copyright (c) Tibor Kulcar & TrSek alias Zdeno Sekerak } { Program sluzi na editaciu a vytvarania zvukovych efektov } { } { PODAKOVANIE: } { Aspon takto by som chcel podakovat spoluautorovi Tiborovi za to, ze } { program vobec existuje. Povodne bol jeho dielom. Ako autor som sa dovolil } { pripisat preto, ze som urobil viacej hlavne vizualnych a GUI uprav. } { } { Datum:01.05.2000 http://www.trsek.com } {$M 21192,0,55360} Program Sounder; Uses crt,dos,trsek; Const Max_noty = 1600; noty:array[0..23] of word= (0,67,78,87,98,110,124,131,147,165,175,196,220,247,262,294,330, 349,392,440,494,523,587,659); textnoty:array[1..23] of string= ('d2','e2','f2','g2','a2','h2','c3','d3','e3','f3','g3','a3','h3', 'c4','d4','e4','f4','g4','a4','h4','c5','d5','e5'); wiew:array[1..8] of string= (' Help (F1) ', ' Save (F2) ', ' Load (F3) ', ' Clean (F4) ', ' Cela skladba (F5) ', ' Hra tuto stranu (F6) ', ' Rychlost hrania (F9) ', ' Exit (ESC) '); Var k,ch:char; kulti,x1,x2,a,b,i,dlz,but,list,z:integer; xm,ym:integer; { aktualne suradnice mysi } xk,yk:integer; { aktualne suradnice kurzora } xo,yo:integer; { suradnice kde stal kurzor } znako:byte; { aky bol znak kde teraz stoji kurzor } col:byte; hudba:array[1..Max_noty] of word; subory:array[1..255] of string[13]; sp:text; meno:string; finish:boolean; { koniec prace s programom } refresh:boolean; { potrebujem zobrazit aj ked sa nepohol kurzor } mouse,amenu,astrana:boolean; Procedure Init_Mys; var reg:registers; begin reg.ax:=$0000; intr($33,reg); if (reg.ax=0) then mouse:=false else begin { predefinuj kurzor mysi } mouse:=true; reg.ax:=$01; intr($33,reg); end; end; Procedure Zisti_Mys(var x,y,but:integer); var reg:registers; begin if not( mouse ) then exit; reg.ax:=$03; intr($33,reg); x:=trunc(reg.cx/8)+1; y:=trunc(reg.dx/8)+1; but:=reg.bx; end; Procedure Nastav_Mys(var x,y:integer); var reg:registers; begin if not( mouse ) then exit; reg.ax:=$04; reg.cx:=(x-1)*8; reg.dx:=(y-1)*8; intr($33,reg); end; Procedure Zobraz_Mys(zobraz:boolean); var reg:registers; begin if not( mouse ) then exit; if zobraz then reg.ax:=$01 else reg.ax:=$02; intr($33,reg); end; Procedure Pust_Mys; var reg:registers; begin if not( mouse ) then exit; repeat reg.ax:=$06; reg.bx:=$03; intr($33,reg); until (reg.ax=0); end; Procedure WriteXYM(x,y:integer;v_text:string); begin if mouse and (y=ym) and (x<=xm) and ( (x+Length(v_text))>=xm) then begin Zobraz_Mys(false); WriteXY(x,y,v_text); Zobraz_Mys(true); end else WriteXY(x,y,v_text); end; procedure VypisO(t,poc_o,poc:integer); var i:integer; begin i:=t; farba(blue,white); while ((i25))then begin farba(Black,Red); WriteXYM(x,23,' '); WriteXYM(x,24,' '); if(yo in [8,10,12,14,16]) then WriteXYM(x,yo,'Ä') else WriteXYM(x,yo,' '); hudba[x+(list*80)]:=0; end; { polozime notu } if( refresh or (yo=25) or (yo<>y)) then begin farba(Black,LightGreen); hudba[x+(list*80)]:=25-y; WriteXYM(x,y,chr(9)); WriteXYM(x,23,textnoty[25-y][1]); WriteXYM(x,24,textnoty[25-y][2]); end; end; Procedure NotOsnova; var x,y:byte; begin farba(Black,Red); for x:=1 to 80 do for y:=4 to 8 do WriteXYM(x,y*2,'Ä'); end; Procedure Obnov; var pis:string; begin window(1,1,80,25); farba(DarkGray,-1); clrscr; farba(LightBlue,LightGray); WriteXYM(1,25,nothing(79)); WriteXYM(12,25,'Software by KULTI (Tibor KULCAR) & TrSek (Zdeno Sekerak).'); NotOsnova; for i:=1 to 80 do if hudba[i+(list*80)]<>0 then poloz(i,25-hudba[i+(list*80)], true); farba(-1,green); if meno='' then meno:='NONAME.SND'; farba(LightBlue,LightGray); WriteXYM(1,1,nothing(80)); WriteXYM(2,1,'F10-MENU'); farba(-1,White); WriteXYM(35,1,meno); str(list:2,pis); farba(LightGray,Blue);WriteXYM(63,1,chr(30)+chr(30)); farba(Blue,Lightgray);WriteXYM(66,1,'Strana:'+'['+pis+'] '); farba(LightGray,Blue);WriteXYM(78,1,chr(31)+chr(31)); end; function Citaj_file:integer; var poc:integer; sub:SearchRec; begin poc:=0; FindFirst('*',Directory,sub); while (doserror=0) do begin poc:=poc+1; subory[poc]:=sub.name; if (sub.name='.') then dec(poc); findnext(sub); end; FindFirst(meno,Archive or AnyFile,sub); while (doserror=0) do begin poc:=poc+1; subory[poc]:=sub.name; for i:=1 to Length(subory[poc]) do if (subory[poc][i] in ['A'..'Z']) then subory[poc][i]:=chr( ord(subory[poc][i])+( ord('a')-ord('A') ) ); findnext(sub); end; Citaj_file:=poc; end; function Files(x,y:integer;meno:string):string; var w:char; poc,t,tr:integer; Begin KurzorZap(false); poc:=Citaj_file; farba(Blue,White); open_win(x,y,x+16,y+22,'Load',1); VypisO(0,21,poc); farba(Cyan,White); t:=1;tr:=t; { pozicia , relativna pozicia v okne } WriteXYM(2,tr,subory[t]+nothing(12-Length(subory[t]) ) ); repeat w:=readkey; if (w=#13) then if (subory[t][1] in ['.','A'..'Z']) then begin ChDir(subory[t]); poc:=Citaj_file; farba(Blue,White); clrscr; VypisO(0,21,poc); t:=1;tr:=t; w:=#10; { pozicia , relativna pozicia v okne } end; if (w=#0) then begin w:=readkey; if (w=#80) then begin farba(Blue,White); WriteXYM(2,tr,subory[t]+nothing(12-Length(subory[t]) ) ); if (t 1) then begin Dec(t); if (tr>1) then Dec(tr) else VypisO(t-tr,21,poc); end; end; { if (w=#72) then begin } end; { if (w=#0) then begin } farba(Cyan,White); WriteXYM(2,tr,subory[t]+nothing(12-Length(subory[t]) ) ); until (w in [#27,#13]); if (w=#27) then Files:='' else Files:=subory[t]; end; Procedure Clean; begin farba(LightRed,White); open_win(16,10,60,17,' CLEAN ',1); WriteXYM(2,2,'Tymto si pohnojis svoj vytvor (zmazes ho)'); WriteXYM(15,3,'Si si isty ?'); if (otazka(15,5,'Ano','Nie','',Cyan,1)=1) then begin list:=0; for i:=1 to Max_noty do hudba[i]:=0; meno:='NONAME.SND'; end; end; Function Dlzka(dlz:integer):integer; var s:string; cw:byte; begin farba(Blue,White); cw:=get_window(18,10,62,14); open_win(18,10,62,14,'Rychlost',1); WriteXYM(2,2,'Zadaj hodnotu v mikrosekundach:'); str(dlz,s); farba(Black,White); s:=tread(34,2,5,s,#0,#0); val(s,dlz,i); while ( (i>0) and (s<>'') ) do begin delete(s,i,1); val(s,dlz,i); end; dlzka:=dlz; cw:=put_window(cw,18,10,62,14); end; Procedure Save; var x1,x2:integer; begin farba(Blue,White); open_win(3,9,43,15,' Save ',1); WriteXYM(7,1,'Napis mi ako by sa mal tvoj'); WriteXYM(10,2,'vytvor volat,priatelu!'); delete(meno,pos('.',meno),length(meno)-pos('.',meno)+1); farba(Black,White); meno:=tread(5,4,30,meno,#0,#0); if meno='' then begin meno:='NONAME.SND'; exit; end; while ( pos(' ',meno)<>0 ) do delete(meno,pos(' ',meno),1); if( pos('.',meno)=0 )then meno:=meno+'.snd'; for i := 1 to Length(meno) do meno[i] := UpCase(meno[i]); x1:=1; x2:=0; for i:=1 to Max_noty do begin if(( hudba[i]<>0 ) and ( x1=1 )) then x1:=i; if( hudba[i]<>0 ) then x2:=i; end; Assign(sp,meno); ReWrite(sp); for i:=x1 to x2 do WriteLn(sp,noty[hudba[i]]:3,' -',dlz:4,' ms'); Close(sp); end; Procedure Nahraj; var line:string; snum:string; y,p:word; begin assign(sp,meno); {$I-} ReSet(sp); {$I+} if IOResult=0 then begin i:=1; while( not(eof(sp)) and (i=y) and (line[y] in ['0'..'9',' '])) do begin if( line[y] in ['0'..'9'] )then snum:=snum+line[y]; y:=y+1; end; val(snum,p,y); for y:=0 to 23 do if( p>=noty[y] ) then hudba[i]:=y; end; { aka je dlzka hrania noty } y:=1; while((Length(line)>=y) and (line[y]<>'-')) do y:=y+1; delete(line,1,y); repeat val(line,dlz,y); if( y<>0 )then delete(line,y,1); until((y=0) or (Length(line)=0)); if( dlz=0 )then dlz:=100; close(sp); end else begin farba(LightRed,White); open_win(18,10,32,16,' Chyba ',1); WriteXYM(27,11,'Ty error! Takyto subor'); WriteXYM(32,13,'NEEXISTUJE!!!'); farba(Cyan,White); WriteXYM(36,15,' OK '); meno:=''; readln; end; for i := 1 to Length(meno) do meno[i] := UpCase(meno[i]); end; Procedure Load; var menop:string; begin menop:=meno; farba(Blue,White); open_win(27,9,80,16,' Load ',1); WriteXYM(3,2,' Napis mi meno dristu, ktory chces nahrat.'); WriteXYM(3,3,'Alebo stlac ENTER pre vypis vsetkych. (Dristov)'); farba(Black,White); meno:=tread(5,5,40,'*.SND',#0,#0); while( pos(' ',meno )<>0) do delete(meno, pos(' ',meno), 1); Assign(sp,meno); {$I-} ReSet(sp); Close(sp); {$I-} if IOResult<>0 then meno:=files(64,2,meno); if( meno='' )then meno:=menop else nahraj; list:=0; end; Procedure StranaDole; begin list:=list+1; if list>(Max_noty/80-1) then list:=round(Max_noty/80)-1; obnov; end; Procedure StranaHore; begin list:=list-1; if list<0 then list:=0; obnov; end; Procedure Hraj( x_od,x_do:integer ); var i,x1,x2:integer; pis:string; begin x1:=1; x2:=0; obnov; for i:=x_od+1 to x_do do begin if(( hudba[i]<>0 ) and ( x1=1 )) then x1:=i; if( hudba[i]<>0 ) then x2:=i; end; for i:=x1 to x2 do begin farba(Blue,Lightgray); if( round( int(i/80)) <> list )then begin list:=round( int(i/80) ); obnov; end; farba(Black,Cyan); if( hudba[i]<>0 ) then sound( noty[ hudba[i] ] ) else nosound; if ( hudba[i]<>0 ) then begin WriteXYM(i-(list*80),25-hudba[i],chr(9)); if keypressed then if (readkey=#27) then begin nosound; obnov; exit; end; end; delay(dlz); end; nosound; end; Procedure Koniec; begin farba(black,white); window(1,1,80,25); clrscr; farba(blue,lightgray); WriteXYM(1,1,' SOUND PLAYER verion 2.0 Copyright (c) 1990,1994 Software by KULTI & TRSEK. '); halt(0); end; Procedure AppExit; begin farba(LightRed,White); open_win(19,10,63,14,'Chces zdrhnut ?!!',1); if (otazka(16,2,'Ano','Nie','',Cyan,1)=1) then Koniec; end; Procedure Help; var cw:byte; kl:char; begin farba(Blue,White); cw:=get_window(10,3,70,23); open_win(10,2,70,24,'Help (ESC-koniec)',1); WriteXYM(2, 1,'SOUND PLAYER verion 2.0'); WriteXYM(2, 2,'------------------------'); WriteXYM(2, 3,' F1 - tento help'); WriteXYM(2, 4,' F2 - uloz na disk svoj vytvor'); WriteXYM(2, 5,' F3 - nahraj zo suboru'); WriteXYM(2, 6,' F4 - zmaz cely vytvor'); WriteXYM(2, 7,' F5 - hraj celu skladbu'); WriteXYM(2, 8,' F6, medzera, prave tlacitko mysi - hraj aktualnu stranu'); WriteXYM(2, 9,' F9 - zmen dlzku hrania jednej noty'); WriteXYM(2,10,' F10 - menu'); WriteXYM(2,11,' PgUp (ikona vpravo hore) - posun sa o stranu hore'); WriteXYM(2,12,' PgDn (ikona vpravo hore) - posun sa o stranu dole'); WriteXYM(2,13,' Home - posun o toninu vyssie'); WriteXYM(2,14,' End - posun skladbu o toninu nizsie'); WriteXYM(2,15,' Ctrl+left - prisun skladbu zlava k pozicii kurzora'); WriteXYM(2,16,' Ctrl+right - prisun skladbu zprava k pozicii kurzora'); WriteXYM(2,17,' ESC - Koniec programu'); WriteXYM(2,18,' Enter, prave tlacitko mysi - poloz notu'); WriteXYM(2,19,' sipky, mys - pohyb kurzora po notovej osnove'); WriteXYM(2,21,'Copyright (c) 1990,1994,2000 Software by KULTI & TRSEK. '); repeat kl:=readkey; until( kl in [#13,#32,#27]); cw:=put_window(cw,10,3,70,23); end; Procedure Menu; var x,y,i:integer; xm,ym,but:integer; e:char; begin x:=20;y:=5;i:=1; farba(Blue,White); WriteXYM(x,y ,'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ MENU ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»'); WriteXYM(x,y+ 1,'º '+wiew[1]+' º'); WriteXYM(x,y+ 2,'º '+wiew[2]+' º'); WriteXYM(x,y+ 3,'º '+wiew[3]+' º'); WriteXYM(x,y+ 4,'º '+wiew[4]+' º'); WriteXYM(x,y+ 5,'º '+wiew[5]+' º'); WriteXYM(x,y+ 6,'º '+wiew[6]+' º'); WriteXYM(x,y+ 7,'º '+wiew[7]+' º'); WriteXYM(x,y+ 8,'º '+wiew[8]+' º'); WriteXYM(x,y+ 9,'ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ'); WriteXYM(x,y+10,'º Polozenie noty (Enter) º'); WriteXYM(x,y+11,'º º'); WriteXYM(x,y+12,'º Ovladanie '+chr(27)+' '+chr(24)+' '+chr(25)+' '+chr(26)+' º'); WriteXYM(x,y+13,'º º'); WriteXYM(x,y+14,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ'); window(20,10,18,48); farba(cyan,-1); WriteXYM(24,y+i,wiew[i]); repeat e:=#10; if mouse then begin zisti_mys(xm,ym,but); if (but=2) then e:=#27; if (but=1) and (xm>x) and ((x+36)>xm) and (ym in [6..13]) then begin Zobraz_mys(false); farba(Blue,-1); WriteXYM(24,y+i,wiew[i]); { if (i=(ym-5)) then e:=#13 else i:=ym-5;} e:=#13; i:=ym-5; farba(Cyan,-1); WriteXYM(24,y+i,wiew[i]); end; pust_mys; end; if keypressed then begin e:=readkey; if (e=#0) then begin e:=readkey; if (e=#80) then begin farba(blue,-1); WriteXYM(24,y+i,wiew[i]); i:=i+1; if (i>8) then i:=1; end; if (e=#72) then begin farba(Blue,-1); WriteXYM(24,y+i,wiew[i]); i:=i-1; if i<1 then i:=8; end; end; end; farba(cyan,-1); WriteXYM(24,y+i,wiew[i]); if (e=#13) then begin case i of 1 :help; 2 :save; 3 :load; 4 :clean; 5 :hraj(0, Max_noty); 6 :hraj(list*80, (list+1)*80); 7 :dlz:=dlzka(dlz); 8 :AppExit; end; end; Zobraz_mys(true); until (e in [#13,#27]); KurzorZap(false); Zobraz_mys(false); end; Procedure MysMenu(but:byte;var amenu:boolean); begin amenu:=not(amenu); if (amenu) then farba(LightGray,Blue) else farba(Blue,LightGray); WriteXYM(1,1,' F10-MENU '); end; Procedure HoreJeden; var x_od,x_do:integer; begin x_od:=list*80; x_do:=(list+1)*80; for i:=1 to Max_noty do begin { ak uz je tak vysoko ze ju treba zrusit } if( hudba[i]=23 )then begin if( (i>=x_od) and (i<=x_do) )then poloz(i-x_od,25-hudba[i],false) else hudba[i]:=0; end; { treba vykreslit vyssie } if( hudba[i]<>0 )then begin if( (i>=x_od) and (i<=x_do) )then poloz(i-x_od,25-hudba[i]-1,false) else hudba[i]:=hudba[i]+1; end; end; end; Procedure DoleJeden; var x_od,x_do:integer; begin x_od:=list*80; x_do:=(list+1)*80; for i:=1 to Max_noty do begin { ak uz je tak nizko ze ju treba zrusit } if( hudba[i]=3 )then begin if( (i>=x_od) and (i<=x_do) )then poloz(i-x_od,25-hudba[i],false) else hudba[i]:=0; end; { treba vykreslit vyssie } if( hudba[i]<>0 )then begin if( (i>=x_od) and (i<=x_do) )then poloz(i-x_od,25-hudba[i]+1,false) else hudba[i]:=hudba[i]-1; end; end; end; Procedure VlavoJeden(xk:integer); var x_od,x_do:integer; begin x_od:=list*80; x_do:=(list+1)*80+1; for i:=x_od+xk+1 to Max_noty do begin { treba vizualne ??? } if( i<=x_do )then begin if(hudba[i-1]<>0) then poloz(i-x_od-1,25-hudba[i-1],false); if(hudba[i]<>0) then poloz(i-x_od-1,25-hudba[i],false); end; hudba[i-1]:=hudba[i]; end; { nakoniec poslednu notu } if(i<=x_do)then if(hudba[i]<>0) then poloz(i-x_od,25-hudba[i],false); end; Procedure VpravoJeden(xk:integer); var x_od,x_do:integer; begin x_od:=list*80; x_do:=(list+1)*80; for i:=x_od+xk downto 2 do begin { treba vizualne ??? } if( i>x_od )then begin if(hudba[i]<>0) then poloz(i-x_od,25-hudba[i],false); if(hudba[i-1]<>0) then poloz(i-x_od,25-hudba[i-1],false); end; hudba[i]:=hudba[i-1]; end; { nakoniec prvu notu } if(1>x_od)then if(hudba[i]<>0) then poloz(1,25-hudba[1],false); end; BEGIN meno:=''; nosound; for i:=1 to Max_noty do hudba[i]:=0; if( paramcount > 0 )then begin meno:=paramstr(1); nahraj; end; obnov; xk:=77; yk:=11; z:=10; dlz:=100; list:=0; finish:=false; refresh:=true; xo:=xk; yo:=yk; znako:=get_znak( xo, yo, col ); Init_mys; Zobraz_Mys(true); repeat if( refresh or (xk<>xo) or (yk<>yo)) then begin farba(Black,col); WriteXYM(xo,yo, char(znako) ); xo:=xk; yo:=yk; znako:=get_znak( xo, yo, col ); { nova pozicia } farba(Black,Cyan); WriteXYM(xk,yk,chr(14)); KurzorZap(false); refresh:=false; end; if mouse then begin zisti_mys(xm,ym,but); if (xm in [0..10]) and (ym=1) then begin if not(amenu) then MysMenu(but,amenu); end else if amenu then MysMenu(but,amenu); end; { Chce neaku cinnost mysou } if( but<>0 )then begin Zobraz_mys(false); if (but=1) and (xm in [63..64]) and (ym=1) then stranahore; if (but=1) and (xm in [78..79]) and (ym=1) then stranadole; if (but=2) then hraj(list*80, (list+1)*80); { medzera } if (but=3) then AppExit; { ESC } if (but=1) and amenu then menu; if (but<>0) then Pust_Mys; if (but=1) and (ym in [2..22]) then poloz(xm,ym,false) { enter } else obnov; Zobraz_mys(true); end; { Dobyva sa klavesou } if( keypressed ) then begin k:=readkey; if (k=#0) then k:=readkey; Zobraz_mys(false); if (k=#75) then xk:=xk-1; { sipka vlavo } if (k=#77) then xk:=xk+1; { sipka vpravo } if (k=#72) then yk:=yk-1; { sipka hore } if (k=#80) then yk:=yk+1; { sipka dole } { ine znaky } if (k=#27) then finish:=true; { ESC } if (k=#13) then begin { Enter } poloz(xk,yk,false); znako:=get_znak( xo, yo, col ); xk:=xk+1; end; { Znaky F1-F9, PgUp, PgDn, Home, End, Ctrl+sipky } if (k=#59) then help; { F1 } if (k=#60) then save; { F2 } if (k=#61) then load; { F3 } if (k=#62) then clean; { F4 } if (k=#63) then hraj(0, Max_noty); { F5 } if (k in [#64,#32]) then hraj(list*80, (list+1)*80); { F6 } if (k=#67) then dlz:=dlzka(dlz); { F9 } if (k=#68) then menu; { F10 } if (k=#73) then stranahore; { PgUp } if (k=#81) then stranadole; { PgDn } if (k=#55) then HoreJeden; { Home } if (k=#49) then DoleJeden; { End } if (k=#115) then VlavoJeden(xk); { Ctrl+left } if (k=#116) then VpravoJeden(xk); { Ctrl+right } if( k in [#59,#60,#61,#62,#63,#64,#32,#67,#68] )then Obnov; refresh:=true; Zobraz_mys(true); { kontroly } if (yk<2) then yk:=2; if (yk>22) then yk:=22; if (xk<1) then begin xk:=80; stranahore; znako:=get_znak( xo, yo, col ); end; if (xk>80) then begin xk:=1; stranadole; znako:=get_znak( xo, yo, col ); end; end; { if( keypressed ) then begin } if( finish )then begin AppExit; finish:=false; obnov; end; until (false); END.