unit disco;

Interface
uses
sysUtils,forms,dialogs,common,friend;
type              kod_opisu = array[0..265] of typ_skl;
               prosodicFile = file of single;
                   byteFile = file of byte;
var                    opis : string;
 Cpik_file,rms_file,F0_file : prosodicFile;

procedure WordFileInfo(var path:PathStr; var rate:realType;var gain:integer;
                   var data:kod_opisu; var lba_danych:longint;var plikz:typ_sklFile;
                   var lookfor:longint;var lookFor1:word;var opis:string);
 procedure fromDiscToHeap(lookFor:longint; var lba_danych:longint;
  var lba_plackow:word;var tref:TrefTyp;grubosc:word; var  plikz:byteFile;
  var p:boolean;var rez:word;var j:longint;lookfor1:word);

procedure modyf(var path:PathStr;nr_serii:byte;p:boolean;ext:pathStr);
procedure outFileDescr(var plik:typ_sklFile; format:byte;opis:string;rate:real;gain:word);
procedure toDisc(var tref:TrefTyp; RozmSterty:byte; var plik:typ_sklFile;
                 rate:real; Gain,resztka,Grubosc:word;path:PathStr;
                 opis:string;spow:integer;
                var path0:PathStr;nr_serii:byte;format:byte;ext:pathStr);
procedure road(var path:pathStr;cynk:pathStr);
function OpenFile(var FilePath:pathStr; title,ext:shortString):boolean;
function WhereSave(var outFileDir:pathStr; const title,ext:pathStr):boolean;
procedure fileDateSize(const fileDir:pathStr; var date,size:pathStr);

Implementation
uses unit1,newSpectrum,visualization;

 function changeExt(filePath,ext:string):string;
  var i:byte;
  Begin
   for i:=length(filePath) downto 1 do if filePath[i]='.' then break;
   delete(filePath,i+1,length(filePath));
   result:=filePath+'.'+ext;
  End;{changeExt}

 function OpenFile(var FilePath:pathStr; title,ext:shortString):boolean;

 //---------------wskazuje i modyfikuje ścieżkę do pliku danych
 (*
 If no value is assigned to InitialDir, or if the specified directory does not exist, the initial directory
 is controlled by the global ForceCurrentDirectory variable. If ForceCurrentDirectory is true, the dialog opens with
 the current working directory displayed. Otherwise, the dialog opens with either the current working directory or the
 My Documents directory, depending on the version of Windows.
 *)

  begin
   with form1 do
    begin
     opendialog1.FileName:=FilePath;
     opendialog1.Title:=title;
     opendialog1.InitialDir :=extractFileDir(FilePath);
     opendialog1.DefaultExt:=ext;
     //openDialog.Filter := 'Text files|*.txt|Word files|*.doc';
     openDialog1.Filter := 'Dedicated files, i.e. *.'+ext+'|*.'+ext+'|All files, i.e. *.*|*.*';
     ForceCurrentDirectory:=directoryExists(opendialog1.InitialDir);
     if not ForceCurrentDirectory then
       showMessage('[OpenFile] A proposed directory, i.e. the "'+opendialog1.InitialDir+'" does not exist.'#13#10+
       'This directory still will be shown in the dialog window header,'#13#10+
       'but the dialog will be opened with the working directory, i.e. with the "'+getCurrentDir+'" or with the "My Documents" directory instead.'#13#10+
       'You should choose the proper one.');
     result:=opendialog1.Execute();
     FilePath:=opendialog1.FileName;  //full path
     if not result then
     if not fileExists(FilePath) then showMessage('You have not pointed a data file. Default file'#13#10+FilePath+#13#10'does not exist!');
    end;{with}
   InitWrite;
  //inputDirectories(extractFileDir(FilePath)); zablokowano 29.10.05
 end;{OpenFile}

 function WhereSave(var outFileDir:pathStr; const title,ext:pathStr):boolean;

 //---------------points a path, where results should be saved

  var dlg:longint;  logic:boolean;
  begin
   with form1 do
    begin
     Repeat
      repeat
       savedialog1.title:=title+'.'+ext+'"';
       savedialog1.defaultExt:=ext;
       savedialog1.FileName:=outFileDir;
       savedialog1.InitialDir :=extractFileDir(outFileDir);
       savedialog1.Filter := 'Dedicated files, i.e. *.'+ext+'|*.'+ext+'|All files, i.e. *.*|*.*';
       logic:=directoryExists(saveDialog1.InitialDir);
       if logic then
       else showMessage('[WhereSave] A proposed directory, i.e. the "'+savedialog1.InitialDir+'" does not exist.');
       result:=savedialog1.Execute;
       Case result of
        true : begin
                 outFileDir:=savedialog1.FileName;
                 InitWrite;
               end; {case result}
       false : begin
                dlg:=MessageDlg(pchar('[WhereSave] You have''nt pointed a file. Should a default file be pointed, i.e. "'+
                #13#10+OutFileDir+'"?'),mtWarning,[mbRetry,mbAbort,mbYes],1);  //retry=4, abort=3 yes=6
                if logic then showMessage('[WhereSave] Check, whether there was not something wrong with the file path "'
                +OutFileDir+'" or check'+' the init file text, i.e. the "'+InitDir+'". Repair or delete it, espe'+
                'cially when no "Save Dialog"'+' was opened for this file.');
                case dlg of
                 4 : if logic then                  //retry=4; to open save dialog with  initial directory = programDir
                      begin
                       savedialog1.FileName:=extractFileName(OutFileDir);
                       savedialog1.InitialDir :=programDir+'\';
                       result:=savedialog1.Execute;
                      end;
                 6 : result:=true;                   //yes=6
                 3 : exit;                          //abort=3
                end;{case dlg}
               end; {case result=false}
        End;{Case result}
      until result;
      if fileExists(OutFileDir) then
       if application.messageBox(pchar('[WhereSave] File "'+OutFileDir+'" exists, overwrite it?.'),pchar('Saving spectral analyses results'),4)=7 {no}
       then result:=false
       else
     else showMessage('[WhereSave] File "'+OutFileDir+'" does not exists.') ;
     Until result;
    end{with}
 end; {WhereSave}

procedure road(var path:pathStr;cynk:pathStr);
var xekr:byte;
begin
  //write(cons,cynk);
//  textcolor(cyan); xekr:=WhereX;
//  supposeRead(path); modyf(path,0,false,'wrd'); GoToXY(xekr,Wherey);
//  TextColor(white);
 // writeln(cons,path);
end;{road}

procedure WordFileInfo(var path:PathStr; var rate:realType;var gain:integer;
                   var data:kod_opisu;  var lba_danych:longint;
                   var plikz:typ_sklFile;         var lookfor:longint;
                   var lookFor1:word;   var opis:string);
{
Alternatywa dla showWaveHead wywoływanej, gdy czytane są dane typu wave
}
 var i : byte;
   pst : longint;
   fileDescr:string;
 begin
  if fileExists(path) then
  assignFile(plikz,path)  else begin ShowMessage('Plik '+path+' nie istnieje...'#13#10'Przerywam program'); halt end;
  reset(plikz);

 {----------------opis zbioru danych-----------------------------}
  lookFor1:=266;
  if filesize(plikz)=0 then begin showMessage('Plik '+path+' jest pusty!'#13#10'przerywam program..'); halt end;
  For i:=0 to 255 do Read(plikz,data[i]);
  For i:=0 to 255 do Opis[i]:=char(data[i]);
  fileDescr:='Opis danych '+path+#13#10'Plik zawiera '+intToStr(FileSize(plikz))+' elementów'+
   #13#10+opis+#13#10'Data zalozenia pliku: ';
  For i:=1 to 4 do begin Read(plikz,data[i]); fileDescr:=fileDescr+intToStr(data[i]) end;
  fileDescr:=fileDescr+#13#10'godz - min - s - ss ';
  For i:=5 to 8 do begin Read(plikz,data[i]); fileDescr:=fileDescr+intToStr(data[i])+'-' end;
  fileDescr:=fileDescr+#13#10;
  Read(plikz,data[9]);  rate:=data[9];
  Read(plikz,data[10]); Gain:=data[10];
  lba_danych:=FileSize(plikz)-FilePos(plikz);
  fileDescr:=fileDescr+#13#10'rate='+floatToStr(rate)+#13#10'wzmocnienie='+intToStr(gain)+
   #13#10'liczba danych='+intToStr(lba_danych);
  showMessage(fileDescr);
  lookfor:=lookFor1;
 end;{WordFilenfo}


 procedure fromDiscToHeap(lookFor:longint; var lba_danych:longint;
  var lba_plackow:word;var tref:TrefTyp;grubosc:word; var  plikz:byteFile;
  var p:boolean;var rez:word;var j:longint;lookfor1:word);

  label 1;
  var t:variant;
  var i,k,l : longint;                  {lookFor - poczatek czytania,j - liczba wczytanych danych}
   arr2 : array[1..2] of byte;          //tablica pośrednicząca w czytaniu pliku
 begin
  Form1.StatusBar1.Panels.Items[0].Text:='Z dysku na sterte; czytanie rozpoczynamy od nr-u '+intToStr(lookfor-lookfor1);
  i:=filePos(plikz);
  l:=grubosc+1; j:=0; p:=false; seek(plikz,lookFor);
  for k:=0 to lba_plackow do
   begin
    i:=0;
    Form1.StatusBar1.Panels.Items[1].Text:='Ładujemy plaster nr '+intToStr(k);
    Repeat
     if EOF(plikz) then
      begin
       t:='Koniec pliku, załadowano '+intToStr(j)+' danych w '+intToStr(k+1)+' warstwach'#13#10'po '+intToStr(l)+' bajtów każda';
       goto 1
      end
     else
      begin
       inc(j);                     //j - licznik całkowity
        if (j>=lba_danych) then
         begin
          t:='Koniec danych, załadowano '+intToStr(j)+' danych w '+intToStr(k+1)+' warstwach'#13#10'po '+intToStr(l)+' bajtów każda.';
          goto 1
         end;
       read(plikz,arr2[1],arr2[2]);   //zmiana czytania 29.06.05
       tref[k]^[i]:=smallInt(arr2);   //celem odczytu plików wav (było czytanie tref[k]^[i]
       inc(i);
      end;
    until (i>=l) or (j>=lba_danych); {koniec ladowania kolejnego plastra}
    Form1.StatusBar1.Panels.Items[2].Text:=' załadowano już '+intToStr(j)+' danych';
   end;{for - koniec sterty}
 if j<lba_danych then
  begin
   p:=True;
   t:='Zabrakło miejsca na stercie dla '+intToStr(lba_danych-j-lookFor)+' danych!'#13#10+
   'Powiększ stertę, stała maxLbaBlok w Common, obecnie='+intToStr(maxLbaBlok)+'.';
   lba_plackow:=k;
  end {if}
 else t:='Błąd, załadowano '+intToStr(j)+' danych, tj. o '+intToStr(j-lba_danych)+' więcej niż jest w zbiorze dyskowym!'#13#10;
1: t:=t+#13#10'Ostatni załadowany plaster zawiera '+intToStr(i+1)+' danych';
showMessage('Procedura fromDiscToHeap.'#13#10+t);
 if i<l then rez:=i else rez:=0;
 Close(plikz);
// inline($FB);
 end; {fromDiscToHeap}



{
 procedura modyfikuje nazwe zbioru w sciezce dostepu, tj.:
  - dodaje numer (generowanego gdzie indziej) zbioru, jesli zm. nr_odc>0
  -  -     litere P jesli p=true (przerwanie czytania wskutek przep. sterty
  - przycina rozszerzenie do 3 liter
  - dodaje rozszerzenie .[ext] jesli nie wyszczeg. innego i nie ma kropki
  - podstawia nazwe locDrv+'\Pomiary.ext jesli path = '' lub='.' lub length =1
  - dodaje nazwe dysku locDrv jesli nie podano innej
}

procedure modyf(var path:PathStr;nr_serii:byte;p:boolean;ext:pathStr);
 var
      i,l,d,k,n : byte;
            lancuch : string;
 begin
  n:=length(path);
  if (path ='') or (n=1) or (path[1]='.') then
      path :=locDrv+'\Pomiary.'+ext;
  if (path[2]<>':') and (path[3]<>'\') then path := locDrv+'\'+path;
  n:=length(path);
  i:=n+1;
  repeat                                       {wykryc pozycje' ostatniego \}
   i:=i-1;
  until (i<=0) or (path[i]='\');
  if i=n then path:=path +'Pomiary';
  k:=pos('.',path);
  if (k=0)  then path := path + '.'+ext;
  k:=pos('.',path);
  delete(path,i+8+1,k-i-1-8);              {obciac nazwe do 8-miu znakow}
  k:=pos('.',path);
  if nr_serii>0 then str(nr_serii,lancuch) else lancuch:='';
  if p then lancuch :=lancuch + 'P';
  l:=length(lancuch);
  n:=length(path);
  if n-k-3 > 0 then delete(path,k+3+1,n-k-3);    {obciac rozszerz. do 3 zn.}
  d:=k-i-1+l;
  if d <= 9 then Insert(lancuch ,path,k)    {wstawic zmodyfikowany odcinek}
  else                                         {przed kropka}
   begin                                       {obciac nazwe i wstawic jw.}
    Delete(path,8-l+1+i,k-9+l-i);
    Insert(lancuch,path,pos('.',path));
   end;{if d}
 end;{modyf}
procedure outFileDescr(var plik:typ_sklFile; format:byte;opis:string;rate:real;gain:word);
 var opis_danych : kod_opisu;
        data_zal : array[1..8] of typ_skl;
             i,j : word;
 begin

  {--------------opis zbioru---------------------------}
  case format of
   0: { Wyniki beda bez naglowka informacyjnego};
   1:begin
    for i:=0 to 265 do opis_danych[i] := typ_skl(' ');
    for i:=0 to 255 do opis_danych[i]:=typ_skl(opis[i]);
    for i:=0 to 255 do write(plik,opis_danych[i]);
//    GetDate(data_zal[1],data_zal[2],data_zal[3],data_zal[4]);
    for i:=1 to 4 do opis_danych[i]:=typ_skl(data_zal[i]);
//    GetTime(data_zal[5],data_zal[6],data_zal[7],data_zal[8]);
    for i:=5 to 8 do opis_danych[i]:=typ_skl(data_zal[i]);
    j:=round(rate);
    opis_danych[9]:=typ_skl(j);
    opis_danych[10]:=typ_skl(gain);
    for i:=1 to 10 do write(plik,opis_danych[i]);
   end;{case 1}
   2:begin
    i:=0;
    repeat
      opis_danych[i]:=swap(typ_skl(opis[i+2])) or typ_skl(opis[i+1]);
      write(plik,opis_danych[i]);
      i:=i+2;
    until i=48;
    end;{case 2}
   end;{case format}
 end;{outFileDescr}

procedure toDisc(var tref:TrefTyp; RozmSterty:byte; var plik:typ_sklFile; rate:real;
                 Gain,resztka,Grubosc:word;path:PathStr;opis:string;spow:integer;
                 var path0:PathStr;nr_serii:byte;format:byte;ext:pathStr);

 var
                  i,j,k,l,m : longint;
                 
                        dysk : word;
                        znak : char;
                         zmp : shortint;
                         los : boolean;

 begin
//  TextColor(blue);writeln(cons,'Na dysk'); TextColor(white);
  m:=grubosc+1; los:=True; rate:=rate*spow;
  if resztka > 0 then m:=RozmSterty*m+resztka else m:=(RozmSterty+1)*m;

 repeat

  los:=True;
  if path = '' then path := locDrv+'\pomiary.'+ext;
 (* writeln(cons,'Mamy do zaladowania na dysk ',m:7,' danych');
  write(cons,'zbior opisany jako '); //TextColor(brown);
  writeln(cons,' ',opis);
  //TextColor(White);
  write(cons,'Dane te sa ladowane do ');
  //TextColor(green);
  writeln(cons,path);
  //TextColor(white); *)
  assignFile(plik, path);
  rewrite(plik);
  case path[1] of
   'A','a' : dysk := 1;
   'B','b' : dysk := 2;
   'C','c' : dysk := 3;
   'D','d' : dysk := 4;
   'E','e' : dysk := 5;
   'F','f' : dysk := 6
    else     dysk := 0
  end; {case}
//  i:=DiskFree(dysk);
  if format =0 then j:=0 else if format=1 then j:=265 else j:=24;
  //writeln(cons,'Dysk ',path[1],' zawiera ',i,
    //      ' wolnych bajtow, co daje  ',i shr 1,' danych typu Word');
  if (SizeOf(typ_skl)*m +j) > i then
   begin //TextColor(red);
    //writeln(cons,'Dane nie pomieszcza sie zmien dysk lub sciezke dostepu; Enter!');
    //znak:=ReadKey;
    los:=False; //GoToXY(1,WhereY-5);
//    for i:=1 to 5 do DelLine;
    //write(cons,'czytac nowa sciezke? - t/n ');
    //znak:=ReadKey;
     //write(cons,znak);
     if znak='t' then
      begin
//       TextColor(red);
 //write(cons,' Nowa path '); //i:=WhereX;
       path :='';
//       puc;
       repeat
        //znak:=ReadKey;
   //      write(cons,znak);
        if (znak<>#13) and (znak<>#10) then path:=path+znak;
//        i:=WhereX;
//         puc;
       until (znak=#13) or (znak=#10);
       if path=#13 then path:='';
       modyf(path,nr_serii,false,ext); //TextColor(white);
       //GoToXY(i,WhereY); ClrEol;
     //  writeln(cons,path); path0:=path;
      end
      else;// writeln(cons);
//    TextColor(white);
   end;{if SizeOf}
  outFileDescr(plik,format,opis,rate,gain);
 until los;
  {-------------zapis wynikow pomiarow---------------------}
  if resztka > 0 then zmp := RozmSterty - 1 else zmp:=RozmSterty;
  j:=-1;
  for i:=0 to zmp do
   begin
    //writeln(cons,'Ladujemy na dysk plaster nr ',i:3,' dotad zaladowano ',
   // i*(j+1):7,' danych');
     for j :=0 to grubosc do write(plik,tref[i]^[j]);
     j:=grubosc;
   end;{i}
   k:=0;
   if resztka > 0 then
    begin
     //writeln(cons,'Ladujemy resztke zawierajaca ',resztka,' danych ','dotad zaladowano ',i*(j+1),' danych');
     for k:= 0 to resztka-1 do
     write(plik,tref[RozmSterty]^[k]);
     k:=resztka-1;
    end;{resztka>0}
    l:=FileSize(plik);
    close(plik);
 // writeln(cons,'Na dysk zaladowano ',((i+1)*(j+1)+k+1):7,  ' danych',#10#13,
   //       'powinno byc        ',m:7,#10#13,
  //'utworzony zbior zawiera ogolem ',l,' elementow');
 end;{toDisc}

 procedure pauza;
 var x,y : byte;
 begin
//    x:=WhereX; y:=WhereY;
          //puc;
          // write(cons,' Pauza - ENTER!');
           //repeat until KeyPressed; puc;
//  GoToXY(x,y); write(cons,'               '); GoToXY(x,y);
 end;{pauza}


  procedure ZDysku(pocz:longint;count:word; var  plik : typ_sklFile; var wyniki : obs);

  var i,j,l : longint;
     pomiar : typ_skl;//word; zmiana29.06.05 aby można było czytać pliki wav
 begin
  l:=pocz; inc(l,count); j:=0; i:=pocz; Seek(plik,i);
  Repeat
   if EOF(plik) then
    begin
     //writeln(cons,'koniec zbioru, wczytano ',i-1,' danych'); i:=l; pauza;
    end
    else
     begin
      read(plik,pomiar);
      wyniki[j] := pomiar;
      inc(j);
      inc(i);
     end;
 until i>=l;
 end; {ZDysku}

procedure fileDateSize(const fileDir:pathStr; var date,size:pathStr);
var
searchrec:tsearchrec;
Begin
 date:='not found'; size:='?';
 if fileexists(FileDir) then
 begin
  findFirst(FileDir,faAnyFile,searchRec);
  size:=intTostr(searchRec.Size);
  date:=DateTimeToStr(FileDateToDateTime(searchRec.time));
 end;
End;

BEGIN
 Tfilerec(Cpik_file).mode:=fmClosed;
 Tfilerec( rms_file).mode:=fmClosed;
 Tfilerec( F0_file).mode:=fmClosed;
END.
