Umiestnenie súboru www.TrSek.com/cover/ales/speaker.pas{ SPEAKER.PAS Copyright (c) Ales Kucik }
{ Tento program spoustejte z DOSu (WINxx restartujte do DOSu)! }
{ Prehraje vsechny soubory WAV,VOC,RAW soubory, ale hudbu uslysite }
{ jen u 8bit zvukovych souboru bez komprese a musi byt nahrany mono.}
{ }
{ Datum:29.11.2002 http://www.trsek.com }
type
Tdata = array[1..max_data] of byte;
Pdata = ^Tdata;
Tinfo = record
filename:string[64];
file_size:longint;
frequence:longint;
mute:byte;
oversample:byte;
sample1D:Pdata;
sample2D:Pdata;
sample1:word; {delka samplu}
sample2:word;
end;
var
speed,clock:word;
safeAttr:byte;
o_sample:byte {promenne pro New8};
size_sample,l:word;
end_play:boolean;
info:Tinfo;
sample:Pdata;
changer:boolean;
POld8:pointer;
Old8:procedure;
procedure MakeMenu;
begin
textbackground(black);
textcolor(blue);
NormalWin(1,1,80,25);
textcolor(yellow);
writeXY(8,3,'PPP CC SS PPP EEEE AA K K EEEE RRR ');
writeXY(8,4,'P P C S P P E A A K K E R R');
writeXY(8,5,'PPP C ## SS PPP EE AAAA KK EE RRR ');
writeXY(8,6,'P C S P E A A K K E R R');
writeXY(8,7,'P CC SSS P EEEE A A K K EEEE R R PLAYER v1.00 ');
textcolor(blue);
HWriteXY(freqX,freqY,1,bright,'Frequence:');
HWriteXY(overX,overY,1,bright,'Oversample:');
HWriteXY(muteX,muteY,1,bright,'Mute:');
HWriteXY(fileX,fileY,2,bright,'File:');
writeXY(67,24,'ESC=EXIT');
textbackground(cyan);
NormalWin(buttonX1,buttonY1,buttonX2,buttonY2);
end;
procedure Init;
procedure MakeWarning;
begin
textcolor(yellow);
textbackground(red);
NormalWin(1,1,80,25);
writexy(4, 2,'!!! VAROVANI PROZACATEK !!!');
writexy(4, 3,'-SPOUSTEJTE PROGRAM Z DOSU (alespon emulovaneho Dosu)!!');
writexy(4, 4,'-zvuk muze byt velice hlucny');
writexy(4, 5,'-zvuk muze byt na nekterych PC-Speakerech hrozny/zadny');
writexy(4, 6,'-program prehrava soubory WAV,VOC,RAW a mozna i jine');
writexy(4, 7,' ktere jsou bez komprese, 8bit, mono');
writexy(4, 8,'-A samozrejme program pouzivate na vlastni nebezpeci!');
writexy(4,10,'!!! WARNING AT FIRST !!!');
writexy(4,11,'-EXECUTE PROGRAM IN DOS (at least emulated Dos)!!');
writexy(4,12,'-sound can be very loudy');
writexy(4,13,'-sound can be at some PC-Speakers awful/none');
writexy(4,14,'-you can play WAV,VOC,RAW files and maybe something else');
writexy(4,15,' but they have to be without compress, 8bit, mono');
writexy(4,16,'-you use this program on your own risk!');
writexy(4,23,'Dotazy/Questions: ales.prog@centrum.cz');
writexy(4,24,' Neco stiskni/Press something');
getKey;
end;
var i:byte;
begin
cursorOff;
safeAttr:=textAttr;
MakeWarning;
if not(ExMouse) then
begin
ErrorMes('Nenasel jsem mys!/I didn''t foud mouse');
getKey;
end
else CursorEnable;
MakeMenu;
{ulozeni zakladni obrazovky}
move(mem[videoSeg:page0],mem[videoSeg:page1],page_size);
with info do
begin
filename:='';
file_size:=0;
frequence:=def_freq;
mute:=def_mute;
oversample:=def_over;
sample1D:=nil;
sample2D:=nil;
sample1:=0;
sample2:=0;
end;
end;
procedure Finish;
begin
cursorOn;
if ExMouse then CursorDisable;
TextAttr:=safeAttr;
clrscr;
end;
procedure New8; interrupt;
begin
port[timer_2]:=sample^[l];
dec(clock);
inc(o_sample);
if clock= 0 then
begin
clock:= speed;
inline($9c);
Old8;
end;
if o_sample>= info.oversample then
begin
o_sample:=0;
inc(l);
if l> size_sample then
begin
l:=1;
changer:=not(changer);
if changer then
begin
sample:=info.sample1D;
size_sample:=info.sample1;
end
else
begin
sample:=info.sample2D;
size_sample:=info.sample2;
end;
end;
end_play:= (sample^[l]=$FF);
end;
port[$20]:=$20;
end;
procedure Play;
var
prev_changer:boolean;
OurFile:file;
Timer_value:byte; {prejmenovat na speaker value}
i:word;
state,num,hor,ver:word;
begin
{Pripravit na prehravani}
l:=1;
speed:=round(info.frequence/18.2);
clock:=speed;
changer:=false; {prvni se bude prehravat sample1}
prev_changer:=true;
o_sample:=0;
new(info.sample1D);
new(info.sample2D);
assign(OurFile, info.filename);
{$I-}
reset(OurFile,1);
{$I+}
If IOresult <> 0 then halt(1);
blockread(OurFile, info.sample2D^, max_data, info.sample2);
for i:=1 to info.sample2 do
info.sample2D^[i]:=info.sample2D^[i] shr info.mute;
if info.sample2<max_data then info.sample2D^[info.sample2+1]:=$FF;
sample:=info.sample2D;
size_sample:=info.sample2;
delay(1000);
{inicializace
nastaveni timeru
prohozeni New8 a Old8
}
{Timer2}
port[timer_control]:=$90;
{napojeni na speaker}
timer_value:=port[speaker_port];
timer_value:=timer_value or 3;
port[speaker_port]:=timer_value;
{Presmerovani Int 8}
GetIntVec(8,POld8);
GetIntVec(8,@Old8);
SetIntVec(8,addr(New8));
{nastaveni timeru 0}
port[timer_control]:=$36;
port[timer_0]:=((base_timer div info.frequence)mod 256);
port[timer_0]:=((base_timer div info.frequence)div 256);
repeat
if keypressed then end_play:= getKey in [27,83,115];
if ExMouse then
begin
RealState(2,state,num,hor,ver);
if (state<>0)and(hor>=buttonX1)and(hor<=buttonX2)and
(ver>=buttonY1)and(ver<=buttonY2)then end_play:=true;
end;
while changer xor prev_changer do
begin
if changer then
begin
blockread(OurFile, info.sample2D^, max_data, info.sample2);
for i:= 1 to info.sample2 do
info.sample2D^[i]:=info.sample2D^[i] shr info.mute;
if info.sample2<max_data then info.sample2D^[info.sample2+1]:=$FF;
end
else
begin
blockread(OurFile, info.sample1D^, max_data, info.sample1);
for i:= 1 to info.sample1 do
info.sample1D^[i]:=info.sample1D^[i] shr info.mute;
if info.sample1<max_data then info.sample1D^[info.sample1+1]:=$FF;
end;
prev_changer:=changer;
end;
until end_play;
{obnova timeru
prohozeni New8 za Old8}
port[timer_control]:=$36;
port[timer_0]:=lo(65535);
port[timer_0]:=hi(65535);
SetIntVec(8,POld8);
timer_value:=port[speaker_port];
timer_value:=timer_value and 252;
port[speaker_port]:=timer_value;
port[timer_control]:=$B6;
dispose(info.sample1D);
dispose(info.sample2D);
close(OurFile);
{Navraceni do puvodniho stavu}
end;
procedure RefreshMenu;
var s:string;
begin
move(mem[videoSeg:page1],mem[videoSeg:page0],page_size);
textcolor(lightred);
textbackground(cyan);
HWriteXY(buttonX1+3,buttonY1+1,1,blue,'PLAY');
textcolor(lightred);
textbackground(black);
with info do
begin
str(frequence,s);
writeXY(freqX+11,freqY,s +' Hz');
str(oversample,s);
writeXY(overX+12,overY,s);
str(mute,s);
writeXY(muteX+6,muteY,s);
writeXY(fileX+6,fileY,filename);
end;
end;
procedure frequence;
var
s,r:string[6];
code:integer;
num:longint;
begin
textcolor(blue);
normalWin(freqx-2,freqy-1,freqx+20,freqy+1);
textcolor(green);
writeXY(freqx,freqy,'Frequence:');
window(freqx+10,freqy,freqx+18,freqy);
cursorOn;
textbackground(cyan);
textcolor(yellow);
clrscr;
readln(s);
val(s,num,code);
cursorOff;
window(1,1,80,25);
if code<>0 then
begin
ErrorMes('Pis pouze cisla!/Write only numbers!');
getKey;
end
else
if (num<min_freq)or(num>max_freq) then
begin
str(min_freq,s);
str(max_freq,r);
ErrorMes('Pouze cislo v intervalu/Only number of range <'+s+','+r+'>');
getKey;
end
else info.frequence:=num;
end;
procedure oversample;
var
s,r:string[2];
code:integer;
num:byte;
begin
textcolor(blue);
normalWin(overx-2,overy-1,overx+15,overy+1);
textcolor(green);
writeXY(overx,overy,'Oversample:');
window(overx+11,overy,overx+13,overy);
cursorOn;
textbackground(cyan);
textcolor(yellow);
clrscr;
readln(s);
val(s,num,code);
cursorOff;
window(1,1,80,25);
if code<>0 then
begin
ErrorMes('Pis pouze cisla!/Write only numbers!');
getKey;
end
else
if (num<min_over)or(num>max_over) then
begin
str(min_over,s);
str(max_over,r);
ErrorMes('Pouze cislo v intervalu/Only number of range <'+s+','+r+'>');
getKey;
end
else info.oversample:=num;
end;
procedure mute;
var
s,r:string[1];
code:integer;
num:byte;
begin
textcolor(blue);
normalWin(mutex-2,mutey-1,mutex+9,mutey+1);
textcolor(green);
writeXY(mutex,mutey,'Mute:');
window(mutex+5,mutey,mutex+7,mutey);
cursorOn;
textbackground(cyan);
textcolor(yellow);
clrscr;
readln(s);
val(s,num,code);
cursorOff;
window(1,1,80,25);
if code<>0 then
begin
ErrorMes('Pis pouze cisla!/Write only numbers!');
getKey;
end
else
if (num<min_mute)or(num>max_mute) then
begin
str(min_mute,s);
str(max_mute,r);
ErrorMes('Pouze cislo v intervalu/Only number of range <'+s+','+r+'>');
getKey;
end
else info.mute:=num;
end;
procedure changeFile;
var
s:string[64];
check_file:file;
result:searchRec;
i:byte;
dot:boolean;
begin
dot:=false;
textcolor(blue);
normalWin(filex-2,filey-1,filex+72,filey+1);
textcolor(green);
writeXY(filex,filey,'File:');
window(filex+5,filey,filex+70,filey);
cursorOn;
textbackground(cyan);
textcolor(yellow);
clrscr;
readln(s);
for i:=1 to length(s) do dot:=(s[i]='.')or dot;
if not(dot) then s:=s+'.*';
cursorOff;
window(1,1,80,25);
findfirst(s,anyfile,result);
if doserror<>0 then
begin
ErrorMes('Je mi lito, ale nic jsem nenasel/I''m sorry, but I found nothing');
getKey;
end
else
begin
assign(check_file,s);
{$I-}
reset(check_file);
close(check_file);
{$I+}
if IOresult<>0 then
begin
ErrorMes('Oops!Neco se posralo!/Oops!Something goes wrong!');
getKey;
end
else
begin
info.filename:=s;
info.file_size:=result.size;
end;
end;
end;
procedure Init_play;
begin
if info.filename=''then
begin
ErrorMes('Nejprve zvol soubor!/First choose file!');
getKey;
end
else
begin
textcolor(lightred);
textbackground(cyan);
HWriteXY(buttonX1+3,buttonY1+1,1,blue,'STOP');
Play;
end;
end;
function ActionMenu:byte;
var
act:byte;
state,number,hor,ver:word;
begin
act:=0;
repeat
if ExMouse then
begin
RealState(2,state,number,hor,ver);
if state<>0 then
begin
{freq}
if (hor>=freqX)and(hor<freqX+9)and(ver=freqY) then act:=1;
{over}
if (hor>=overX)and(hor<overX+10)and(ver=overY) then act:=2;
{mute}
if (hor>=muteX)and(hor<muteX+4)and(ver=muteY) then act:=3;
{ChFile}
if (hor>=fileX)and(hor<fileX+4)and(ver=fileY) then act:=4;
{InitPLay}
if (hor>=buttonX1)and(hor<=buttonX2)and
(ver>=buttonY1)and(ver<=buttonY2)then act:=5;
end;
end;
if keypressed then
case getKey of
70,102: act:=1;
79,111: act:=2;
77,109: act:=3;
73,105: act:=4;
80,112: act:=5;
27 : act:=6;
end;
until act in [1..6];
ActionMenu:=act;
end;
begin
{Nejaky sracky s nactenim, prostredi atd.}
{nastavit info.oversample
info.frequece}
Init;
repeat
RefreshMenu;
case ActionMenu of
1: frequence;
2: oversample;
3: mute;
4: changeFile;
5: Init_play;
6: end_prog:=true;
end;
until end_prog;
Finish;
end.