Prehraje zvuk vo formáte wav na speakery PC

{ 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 }
 
program PCspeaker;
uses crt,dos,textscr,mouse;
 
const
  max_data =     64000;
 
  base_timer=    1193180;
 
  min_freq =    1;
  max_freq =    128000;
  def_freq =    16000;
 
  min_over =    1;
  max_over =    16;
  def_over =    1;
 
  min_mute =    0;
  max_mute =    6;
  def_mute =    2;
 
  timer_0 =    $40;
  timer_2 =    $42;
  timer_control = $43;
  speaker_port =  $61;
 
  freqX=5;
  freqY=10;
 
  overX=5;
  overY=12;
 
  muteX=5;
  muteY=14;
 
  fileX=5;
  fileY=18;
 
  buttonX1=35;
  buttonY1=21;
  buttonX2=44;
  buttonY2=23;
 
  bright=green;
 
  end_prog:boolean =false;
 
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.