unit disco2;
interface
uses windows,//dos,graph,
common,friend,porto,fft,disco1,grafiti1;
const realTypeSize = sizeOf(realType);

var                                               nowyPlik,plik : typ_sklFile;
                                                           stat : text;
               realTypePlik,fltPlik,revPlik,spktrPlik,cpstrPlik : realPlik;
             path,pathspectr,pathCpstr,pathRev,pathFlt,pathRet : pathStr;
       oRetNaDysk,FileOpen,spND,ospND,oStat,half_win,ocpNd,ocpfnd,
                                  orevNd,cpND,cpfND,revND,retND : boolean;
 fSlope,sSlope,rSlope,cSlope,fBiass,rBiass,sBiass,cBiass,fcpstr : realType;
                                             jumpNbrSamples : word;//real;
   SminRF,CminRF,VminRF,FminRF,SmaxRF,CmaxRF,VmaxRF,FmaxRF,SsRF,
                         CsRF,VsRF,FsRF,FsqRF,SsqRF,CsqRF,VsqRF : double;
                                             resFileNb,ram_disk : char;
                 Sdata_nb,Cdata_nb,Vdata_nb,Fdata_nb,lba_danych : longint;
                                                             cp : word;
                                                ip,ik,fIdx,cIdx : integer;
                                                         winNbr : byte;

var restat: record {korekta fazy - parametry statystyczne wyrownywania zlaczy}
             zm_0,delta_0,s_d_0,abss_d_0,k_s_d_0,s_d,abss_d,k_s_d : real;
            end;{restat}

procedure StatFinish(corr_spectr_nb,ph_corr_nb:word;sort,fall:boolean;
 var stat:Text);
procedure closeRealTypeFiles(var resNd:boolean; var stat:Text);
procedure kontr_otw_zb(resFileNb:char;phase_corr:boolean;var resNd:boolean);
procedure byteFileDisk(var Plik:realPlik;  var xr:TdbArr;cp:word;
 lba_danych,storedDataNb,winNbr,s,sq,min,max:realType;spectrDataNb:longint;
 var openRes:boolean);
procedure RealFileDisk(var Plik:realPlik;cp:word;numer:realtype;
  var min,max,s,sq:double;var data_nb:longint;var xr:rAryType);
procedure retr_res_to_v_disk(var min,max:realType;ram_disk:char);

implementation
 uses disco,sysUtils;

procedure openRealTypeFile(var path:pathStr; ext:extStr;var otworz:boolean;
 var plik:realplik;var nowapath:pathStr;cp,lba_danych,storedDataNb,
 winNbr:realType;half_win:boolean;var slope,biass:realType);
{
----------------otwiera zbior rzeczywisty do zapisu wynikow spectrum

jump - okres probkowania spectrum
rectWinFill - wypelnienie (okno prostok. i Gaussa)
  r1 - =1 jesli okno polowkowe, 0 jesli cale
  cp - lba_probek_FFT/2
}

 type TfilePath = record D:dirStr; N:NameStr; E:extStr; end;

 function Fsplit(const path:string):TfilePath;
  begin
   with result do
    begin
     D:=extractFileDir(path);
     N:=extractFileName(path);
     E:=extractFileExt(path);
    end;
  end;{Fsplit}

 var filePath : TfilePath;
     r1,r2,r3,r4,r5:realType;
     tmp : realType;

 begin
  slope:=1; biass:=0;
  filePath:=Fsplit(path);
  otworz:=false;
  with filePath do nowapath:=D+N+'.'+ext;
  assignFile(plik,nowapath);
  rewrite(plik);
  if half_win then r2:=1 else r2:=0;
  r1:=-1;r5:=RealTypeSize;                      {wsp. kodowania}
  tmp:=rate;
  write(plik,r1,r5,tmp,jump,fcpstr,rectWinFill,winNbr,cp,lba_danych,storedDataNb,r2,slope,biass);
 end;{openRealTypeFile}

procedure closeRealTypeFiles(var resNd:boolean; var stat:Text);
 {zamyka otwarte pliki}

 procedure closerRTF(var logic:boolean;var f:realPlik;
  s,sq,min,max:realType;dtnb:longint);
  begin
   if not logic then
     begin
      s:=s/dtnb; sq:=2*sqrt(sq/dtnb-sqr(s));
      if min<s-sq then min:=s-sq;
      if max>s+sq then max:=s+sq;
      seek(f,11);
      write(f,min,max);
      close(f); logic:=true;
     end;
  end;{closerRTF}

 begin    //---------------------------- closeRealTypeFiles ------------------
  if resNd then
   begin
    fileOpen:=true;
    closerRTF(ospNd,spktrPlik,SsRF,SsqRF,SminRF,SmaxRF,Sdata_nb);{spectrum}
    closerRTF(ocpNd,cpstrPlik,CsRF,CsqRF,CminRF,CmaxRF,Cdata_nb);{cepstrum}
    closerRTF(orevNd,revPlik,VsRF,VsqRF,VminRF,VmaxRF,Vdata_nb); {sp. filtr}
    closerRTF(ocpFnD,FltPlik,FsRF,FsqRF,FminRF,FmaxRF,Fdata_nb); {tr.odwr.cp}
    if not oretNaDysk then
      begin
       oretNaDysk:=true;
       close(realTypePlik);
       erase(realTypePlik);
       if newFileOpened then begin close(nowyPlik); NewFileOpened:=false end;
      end;
    if not oStat then
     begin
      close(stat);
      oStat:=true
     end;
   end{if resNd}
 end;{closeRealTypeFiles}

 procedure Otw_zb_ret_to_vDisk;
  begin
//   assignFile(realTypePlik,virt_disk+':\signal.ret');
   rewrite(realTypePlik);
   oRetNaDysk:=false;
  end;{Otw_zb_ret_to_vDisk}


 procedure OpenStatFile(path:pathStr; extens:extStr;var resNd:boolean;
  var stat:Text);
  var D:dirStr; N:NameStr; E:extStr;
  begin
//   Fsplit(path,d,n,e);
   assignFile(Stat,D+N+'.st'+extens);
   rewrite(stat);
   writeln(stat,'Dane dotycza zbioru ',D+N+'.ST'+extens);
   flush(stat);
   resNd:=true;
   oStat:=false;
  end;{OpenStatFile}

 procedure StatFinish(corr_spectr_nb,ph_corr_nb:word;sort,fall:boolean;
  var stat:Text);
  begin
    if ostat=false then
    begin
     writeln(stat,'--------------------------------------------------------');
     with restat do
      if corr_spectr_nb<>0 then
       begin
        {-----------------------------------srednie}
        s_d_0:=s_d_0/corr_spectr_nb;
        abss_d_0:=abss_d_0/corr_spectr_nb;
        s_d:=s_d/corr_spectr_nb;
        abss_d:=abss_d/corr_spectr_nb;
        k_s_d_0:=k_s_d_0/corr_spectr_nb;
        k_s_d:=k_s_d/corr_spectr_nb;

        {-----------------------------------zapisy na dysk z kontrola sqrt}
        writeln(stat,'Srednie odchylki zwykle i abs i odch. standardowe',
                     ' na zlaczach'#13#10'przed i po korekcie');

        write(stat,'przed kor.: ',s_d_0:12:8,#241);        {- - - - - - - - }
        if k_s_d_0>sqr(s_d_0) then write(stat,sqrt(k_s_d_0-sqr(s_d_0)):12:8)
        else write(stat,'arg sqrt<0!');
        write(stat,';  abs:',abss_d_0:12:8,#241);
        if k_s_d_0>sqr(abss_d_0) then writeln(stat,sqrt(k_s_d_0-sqr(abss_d_0)):12:8)
        else writeln(stat,'arg sqrt<0!');

        write(stat,'   po kor.: ',s_d:12:8,#241);           {- - - - - - - -}
        if k_s_d>sqr(s_d) then write(stat,sqrt(k_s_d-sqr(s_d)):12:8)
        else write(stat,'arg sqrt<0!');
        write(stat,';  abs:',abss_d:12:8,#241);
        if k_s_d>sqr(abss_d) then writeln(stat,sqrt(k_s_d-sqr(abss_d)):12:8)
        else writeln(stat,'arg sqrt<0!');

       end;
     writeln(stat,'---------------------------------------------');
     writeln(stat,'calkowita liczba korekt fazy=..............',ph_corr_nb);
     writeln(stat,'lba  odc. wygenerow. przy korekcie fazy=...',corr_spectr_nb);
     if corr_spectr_nb<>0 then
      writeln(stat,'srednia lba korekt fazy/odcinek=...........',
       ph_corr_nb/corr_spectr_nb:1:2);
     writeln(stat,#13#10'Niektore parametry analiz');
     writeln(stat,'    FFT=.......',count,' pkt;',
            #13#10'    okno nr ...',winNbr,
            #13#10'    jump=......',jump:1:2,' [ms], tj. co ',ik-ip+1,' pkt.;',
            ' wsp. pokrycia okien =',100*(1-(ik-ip+1)/count):1:2,'%');
     write(stat,#13#10'    Sort? ...................',sort:5);
     if sort then writeln(stat,' skladowe wybierane wg. amplitud')
     else writeln(stat,' skladowe wybierane wg. czestotliwosci');
     writeln(stat,'    kolejnosc opadajaca? ....',fall:5);
   end;
  end;{StatFinish}

procedure retr_res_to_v_disk(var min,max:realType;Ram_disk:char);
{
 zapis odcinka sygnalu filtrowanego (=1 jump) na Vdysk w postaci realType
 min, max - wartosci skrajne potrzebne do konwersji na lby typu word
 }
  var i:longint; t5:realType;
 begin
//  i:=diskFree(ord(ram_disk)-64);
  if i>=sizeOf(realType)*jumpNbrSamples+1  then
   for i:=ip to ik do
    begin
     t5:=xr[i];
     if t5<min then min:=t5;
     if t5>max then max:=t5;
     write(RealTypePlik,t5);
    end{for}
  else
   begin
//    music;
//    setFillStyle(1,blue); setColor(white);
//    bar3D(10,8,GetMaxX-24,22,8,true);
//    setColor(yellow);
//    outTextXY(20,12,
//     'Disk '+ram_disk+' Full, sygnal po filtr. cepstr. nie jest dalej rejestrowany !');
    retND:=false;
   end;
 end;{retr_res_to_v_disk}

procedure kontr_otw_zb(resFileNb:char; phase_corr:boolean;var resNd:boolean);
 {
     ocnd - otworz zbior dla zapisu cepstrum, itp.
 fileOpen - to rozkaz: "otwierac zbiory!"
 }
 begin
  if FileOpen then
   begin
    if spND and ospnd then
     openRealTypeFile(path,'SP'+resFileNb,ospnd,spktrPlik,pathspectr,cp,
      lba_danych,storedDataNb,winNbr,half_win,sSlope,sBiass);
    if cpND and ocpnd then
     openRealTypeFile(path,'CP'+resFileNb,ocpnd,cpstrPlik,pathCpstr,cp,
      lba_danych,storedDataNb,winNbr,half_win,cSlope,cBiass);
    if revND and orevnd then
     openRealTypeFile(path,'RV'+resFileNb,orevnd,revPlik,pathrev,cp,
      lba_danych,storedDataNb,winNbr,half_win,rSlope,rBiass);
    if cpfND and ocpfnd then
     openRealTypeFile(path,'FL'+resFileNb,ocpfnd,fltPlik,pathFlt,cp,
      lba_danych,storedDataNb,winNbr,half_win,fSlope,fBiass);
    if retND and oRetNaDysk then Otw_zb_ret_to_vDisk;
    if (phase_corr and oStat and retND) then
     openStatFile(path,resFileNb,resNd,stat);
   end;{if FileOpen}
   FileOpen:=false;
 end;{kontrola_otwarcia_zbioru}

 procedure byteFileDisk(var Plik:realPlik;  var xr:TdbArr;cp:word;
  lba_danych,storedDataNb,winNbr,s,sq,min,max:realType;spectrDataNb:longint;
  var openRes:boolean);

{
---------------zapisuje rzeczywiste wyniki specTRUM do zbioru typu byte

jump - okres probkowania spectrum
rectWinFill - wypelnienie (okno prostok. i Gaussa)
  r1 - =1 jesli okno polowkowe, 0 jesli cale
  cp - lba_probek_FFT/2
}
 type timePoint=array[1..4] of byte;

 var       bytePlik:byteFile;
            path:pathStr;
                 D : dirStr;
                 N : NameStr;
                 E : extStr;
  slope,biass,zmp1 : realType;
                xt : timePoint;
                 i : word;
                 j : longint;
                 k : byte;

 procedure spectrInfo(x:realType);
  {
  zapisuje dane typu real do pliku typu byte
  }
  type spectrDataInfo=array[1..RealTypeSize] of byte;
  var SDI:spectrDataInfo;
        i:byte;
  begin
   SDI:=spectrDataInfo(x);
   for i:=1 to RealTypeSize do write(bytePlik,SDI[i]);
  end;{spectrInfo}
  var tmp:realType;
  begin
//   path:=TfileRec(plik).name;
   informator(path,0,0,0,0);{nazwa aktualnie transf.pliku}
   s:=s/spectrDataNb; sq:=2*sqrt(sq/spectrDataNb-sqr(s));
   if min<s-sq then min:=s-sq;
   if max>s+sq then max:=s+sq;
   slope:=254.99/(max-min);
   biass:=255-254.99/(max-min)*max;
//   Fsplit(path,d,n,e);
   assignFile(BytePlik,D+N+'.TTT');
   rewrite(BytePlik);
   reset(plik);
    read(plik,zmp1);         spectrInfo(0);
    read(plik,zmp1);         spectrInfo(zmp1);         {realTypeSize}
    read(plik,tmp);         spectrInfo(tmp);    rate:=round(tmp);
    read(plik,jump);         spectrInfo(jump);
    read(plik,fcpstr);       spectrInfo(fcpstr);
    read(plik,rectWinFill);         spectrInfo(rectWinFill);
    read(plik,winNbr);       spectrInfo(winNbr);
    read(plik,zmp1);         spectrInfo(zmp1);         {cp}
    read(plik,lba_danych);   spectrInfo(lba_danych);
    read(plik,StoredDataNb); spectrInfo(StoredDataNb);
    read(plik,zmp1);         spectrInfo(zmp1);
    read(plik,zmp1);         spectrInfo(slope);
    read(plik,zmp1);         spectrInfo(biass);
   {-------------------koniec naglowka info--------}
   While not eof(plik) do
   begin
    read(plik,zmp1);         {numer}
    j:=round(zmp1);
    xt:=timePoint(j);
    for i:=1 to 4 do write(bytePlik,xt[i]);
    for i:=0 to cp-1 do
     begin
      j:=filePos(plik);
      read(plik,zmp1);
      if zmp1<min then zmp1:=min; if zmp1>max then zmp1:=max;
      k:=round(zmp1*slope+biass);
      write(bytePlik,k);
     end;{for}
    end;{while}
    close(plik); erase(plik); openRes:=true;
    close(bytePlik);
    rename(bytePlik,path);
  end;{byteFileDisk}

procedure RealFileDisk(var Plik:realPlik;cp:word;numer:realtype;
  var min,max,s,sq:double;var data_nb:longint;var xr:rAryType);
{
-------------------zapisuje wyniki specTRUM NA DYSK--------

- oblicza sumy i okresla wartosci skrajne celem pozniejszego okreslenia prze-
  dzialu ufnosci (dla optymalnego kodowania 8-mio bitowego.

- dpowiednie wartosci powinny uzyskiwac wartosci poczatkowe przy wlaczaniu za-
  pisu na dysk i przy rozpoczynaniu analiz od poczatku (kom. !) i po pozytyw-
  nej odpowiedzi na pytanie o powtorzenie analiz (COMMANDER).

min, max, s, sq - zmienne globalne; minima, maxima, sumy
}
  var i:word; zmp:realType;
  begin
   write(plik,numer);
   inc(data_nb,cp);
   zmp:=xr[0];
   write(plik,zmp);
   for i:=1 to cp-1 do
    begin
     zmp:=xr[i];
     if zmp<min then min:=zmp;
     if zmp>max then max:=zmp;
     s:=s+zmp;
     sq:=sq+sqr(zmp);
     write(plik,zmp);
    end;
  end;{RealFileDisk}

Initialization
// ram_disk:=virt_disk;
 FileOpen:=false;     {otwierac zbiory jak nizej?}
 oStat:=true;         {otworzyc zbior statystyczny dla korekty fazy}
 ospnD:=true;         {otworzyc zbior dla wynikow analizy spectr.}
 spND:=false;
 ocpNd:=true;         {otworzyc zbior dla wynikow analizy cepstr.}
 ocpfnd:=true;        {otworzyc zbior dla wyn. analiz z  filtrem}
 cpND:=false;
 cpfND:=false;
 orevNd:=true;        {otworzyc zbior dla wyn. spktr z filtr. cepstr.}
 revND:=false;
 oRetNaDysk:=true;    {otworzyc zbior dla wyn. odwrotnych po. filtr. cepstr.}
 retND:=false;
 half_win:=false;
 resFileNb:='0';      {numer serii w rozszerzeniu zbioru wynikowego}
 fIdx:=2;             {polozenie kursora w czestotliwosci;
 cIdx:=max_buff div 2;  {polozenie kursora w czasie}
 SminRF:=1e38;          {kodowanie 8-bit; minimum w spectrum}
 CminRF:=1e38;
 VminRF:=1e38;
 SmaxRF:=-1e38;         {kodowanie 8-bit; maximum w spectrum}
 CmaxRF:=-1e38;
 VmaxRF:=-1e38;
 SsRF:=0;               {kodowanie 8-bit; suma w spectrum}
 CsRF:=0;
 VsRF:=0;
 SsqRF:=0;              {kodowanie 8-bit; suma kwadratow w spectrum}
 CsqRF:=0;
 VsqRF:=0;
 Sdata_nb:=0;           {kodowanie 8-bit; liczba danych w zbiorze}
 Cdata_nb:=0;
 Vdata_nb:=0;
 Tfilerec(nowyPlik    ).mode:=fmClosed;
 Tfilerec(plik        ).mode:=fmClosed;
 Tfilerec(realTypePlik).mode:=fmClosed;
 Tfilerec(fltPlik     ).mode:=fmClosed;
 Tfilerec(revPlik     ).mode:=fmClosed;
 Tfilerec(spktrPlik   ).mode:=fmClosed;
 Tfilerec(cpstrPlik   ).mode:=fmClosed;
 TfileRec(plik).name:=
 '                                    '+
 '                                            ';
 Tfilerec(nowyPlik    ).name:=TfileRec(plik).name;
 Tfilerec(realTypePlik).name:=TfileRec(plik).name;
 Tfilerec(fltPlik     ).name:=TfileRec(plik).name;
 Tfilerec(revPlik     ).name:=TfileRec(plik).name;
 Tfilerec(spktrPlik   ).name:=TfileRec(plik).name;
 Tfilerec(cpstrPlik   ).name:=TfileRec(plik).name;
end.