{ Программа сжатия/распаквки звуковых (WAV/PCM) файлов}
{ Автор: Ivan Polyacov, cooler@tut.by}
{ Это очень ранняя версия, когда вы это читаете, существует уже более
  продвинутая версия с улучшенным качеством. Если она вам нужна - обращайтесь}
{$I-,N+}
program cascodec;
 uses crt;
 const
  IDstr:string[24]='CoolSoft Audio Stream ';
  on=true;
  off=false;
 type
  header=record
   ID:array[0..21] of char;
   ver:byte;
   stereo:boolean;
   fsize:longint;
   frames:word;
   freq:word;
   title:string[31];
  end;
  WAVheader=record
   res:array[0..21] of byte;
   chan:word;
   freq,bps:longint;
   res2:array[0..11] of byte;
  end;
 var
  data:array[0..8192] of integer;
  pdata:array[0..4095] of byte;
  sour,dest:array[0..4109] of integer;
  koef:array[0..15] of integer;
  koef2:array[0..15] of byte;
  d1:array[0..4109] of shortint;
  i,j:integer;
  f,f1,f2:file;
  ch:char;
  fname:string;
  stereo:boolean;
  mode:boolean;
  head:header;
  freq:word;
  qual,packsize,frames,totalframes:integer;
 procedure error(mes:string);
  begin
   textcolor(12); writeln; writeln('ОШИБКА!');
   textcolor(14); writeln(mes); textcolor(7); halt;
  end;
 procedure source;
  var
   ID:array[0..10] of char;
   Wavhead:WAVheader;
  begin
   assign(f,paramstr(1));
   reset(f,1);
   blockread(f,ID,8);
   close(f);
   assign(f,paramstr(1));
   reset(f,1);
   if ioresult<>0 then error('Не удается прочитать файл '+paramstr(1));
   if (ID[0]='R') and (ID[1]='I') and (ID[2]='F') and (ID[3]='F') then begin
    blockread(f,wavhead,44);
    if wavhead.chan=2 then stereo:=on else stereo:=off;
    if wavhead.chan*wavhead.freq*2<>wavhead.bps then
     error('Неверный формат WAV-файла '+paramstr(1));
    if wavhead.freq<11000 then error('Слишком низкая частота дискретизации!');
    write('Исходный файл: тип WAV, частота дискретизации: ',wavhead.freq,', режим: ');
    if stereo then writeln('стерео') else writeln('моно');
    mode:=on; freq:=wavhead.freq;
   end else
   if (ID[0]='C') and (ID[1]='o') and (ID[2]='o') and (ID[3]='l') and
     (ID[4]='S') and (ID[5]='o') and (ID[6]='f') and (ID[7]='t') then begin
     blockread(f,head,64);
     if head.ver>$10 then
       error('Для распаковки этого файла требуется более поздняя версия кодека!');
     write('Исходный файл: тип CAS, частота: ',head.freq,', режим: ');
     if head.stereo then writeln('стерео') else writeln('моно');
     writeln('Описание: ',head.title);
     mode:=off; stereo:=head.stereo;
     frames:=0; totalframes:=head.frames;
   end else begin
    writeln('Исходный файл: тип неизвестен (RAW PCM?)');
    write('Введите частоту дискретизации данного файла: '); readln(freq);
    if freq<11000 then
     error('Слишком низкая частота дискретизации!');
    write('Этот файл содержит два стереоканала [Y/n]? '); ch:=readkey;
    writeln(ch);
    if ch in ['Y','y'] then stereo:=on else stereo:=off;
    mode:=on;
   end;
   if mode then begin
    textcolor(14);
    writeln('       Следующий параметр непосредственно определит степень сжатия и качество');
    writeln('звучания.  ВНИМАНИЕ! Одинаковое значение этого параметра не обеспечивает оди-');
    writeln('наковое качество звучания разных файлов! Подбирайте свое значение для каждого');
    writeln('файла. 30-40% - низкое качество, 50% - среднее, 60-70% - высокое.');
    textcolor(11);
    write('Введите количество сохраняемых данных (%) 20..80: '); readln(qual);
   end;
  end;
 procedure destination;
  begin
   if not mode then begin
    fname:=paramstr(2);
    if pos('.',fname)=0 then fname:=fname+'.pcm';
    exit;
   end;
   fname:=paramstr(2);
   if pos('.',fname)=0 then fname:=fname+'.cas';
   writeln('                                                              ');
     write('Введите описание или название файла: '); readln(head.title);
   head.ver:=$10; head.freq:=freq;
   move(IDstr[1],head.ID,22); head.stereo:=stereo;
   frames:=0; totalframes:=filesize(f) div 8192+1;
  end;
 procedure packHuffman;
  var
   i,j,adr,pos,state,n:integer;
   bit,b:byte;
  begin
   i:=0; adr:=0; pos:=0; state:=0;
   repeat
    case state of
     0:if d1[i]=0 then begin bit:=0; inc(i); end
        else begin bit:=1; state:=1; n:=1; end;
     1:if n<abs(d1[i]) then inc(n) else begin state:=2; bit:=0; end;
     2:begin if d1[i]<0 then bit:=0 else bit:=1; state:=0; inc(i); end;
    end;
    b:=b shl 1+bit;
    inc(pos);
    if pos and 7=0 then begin
     pdata[adr]:=b;
     inc(adr);
    end;
   until i=4095;
   repeat
    b:=b shl 1+bit;
    inc(pos);
   until pos and 7=0;
   pdata[adr]:=b;
   inc(adr);
   packsize:=adr;
  end;
 procedure UnPackHuffman;
  var
   pos:word;
   b,bit,n:byte;
   state:byte;
  begin
   pos:=0; n:=0;
   for i:=0 to 4094 do begin
    state:=0;
    repeat
     if pos and 7=0 then b:=pdata[pos div 8];
     bit:=b shr 7; b:=b shl 1;
     inc(pos);
     case state of
      0:if bit=0 then begin d1[i]:=0; state:=3; end
         else begin state:=1; n:=1; end;
      1:if bit=1 then inc(n) else state:=2;
      2:begin if bit=0 then d1[i]:=-n else d1[i]:=n; state:=3; end;
     end;
    until state=3;
   end;
  end;

 procedure encodeframe;
  var
   step,pos1,i,j,kpos,max,n,k,stage:integer;
   sum1,sum2:longint;
  begin
    step:=1; pos1:=0; j:=48; j:=koef[0]*qual; kpos:=0;
    sour[4096]:=sour[4095];
    for i:=0 to 4094 do begin
     dest[i]:=sour[pos1+step] div 4-(sour[pos1] div 8+sour[pos1+step*2] div 8);
     pos1:=pos1+step*2;
     if pos1+step*2>4096 then begin
      inc(kpos);
      j:=koef[kpos]*qual; pos1:=0; step:=step*2;
     end;
    end;
    for i:=0 to 14 do koef[i]:=256;
    koef[11]:=512; koef[12]:=512;
    j:=2048; stage:=0; k:=0;
    for stage:=0 to 4 do begin
     koef[stage]:=2+stage*2; sum1:=0;
     repeat
      inc(koef[stage],koef[stage] div 2);
      if koef[stage]>250+80*stage then break;
      for i:=k to k+j do
       sum1:=sum1+100*abs(dest[i] mod koef[stage]) div (abs(dest[i])+1);
     until (sum1 div j)>qual*4;
     k:=k+j;
     j:=j div 2;
    end;
{    koef[0]:=141;    koef[1]:=316;
    koef[2]:=474;    koef[3]:=454; koef[4]:=549;}
    for i:=0 to 14 do koef[i]:=(koef[i] div (i+3))*(i+3);
    j:=2048; sum1:=0; max:=2048; sum2:=0; n:=0;
    for i:=0 to 4094 do begin
     if i=j then begin
      max:=max div 2; j:=j+max;
      n:=n+1;
     end;
 {    d1[i]:=round(dest[i]/koef[n]);}
      d1[i]:=dest[i] div koef[n];
    end;
    d1[4095]:=sour[0] div 512;
    d1[4096]:=sour[4095] div 512;
    for i:=0 to 4 do d1[4097+i]:=koef[i] div (i+3);
    PackHuffman;
    blockwrite(f2,packsize,2);   blockwrite(f2,pdata,packsize);
    blockwrite(f2,d1[4095],7);
  end;
 procedure decodeFrame;
  var
   step,pos1,pos2,pos3,i,j,kpos:integer;
  begin
   unpackHuffman;
   for i:=0 to 14 do koef[i]:=256;
   koef[11]:=512; koef[12]:=512;
   for i:=0 to 4 do koef[i]:=d1[4097+i]*(i+3);

   fillchar(dest,sizeof(dest),0);

   dest[0]:=d1[4095]*256;
   dest[4096]:=d1[4096]*256;
   step:=2048; pos2:=4094; pos1:=0; pos3:=pos2; j:=koef[11]*2; kpos:=11;
   for i:=0 to 4094 do begin
    dest[pos1+step]:=(dest[pos1] div 2+dest[pos1+step*2] div 2)+d1[pos2]*j;
    inc(pos2);
    pos1:=pos1+step*2;
    if pos1>=4096 then begin
     pos1:=0; dec(kpos); j:=koef[kpos]*2;
     pos2:=pos3-4096 div step;
     step:=step div 2; pos3:=pos2;
    end;
   end;
   for i:=0 to 4095 do
    if abs(dest[i])<16380 then dest[i]:=dest[i]*2 else begin
     if dest[i]<0 then dest[i]:=-32760 else dest[i]:=32760;
    end;
  end;
 procedure run;
  var
   rsize:word;
   done:boolean;
  begin
   done:=off;
   assign(f2,fname);
   rewrite(f2,1);
   if mode then blockwrite(f2,head,sizeof(head));
   textcolor(10);
   if mode then write('Упаковка:') else write('Распаковка:');
   repeat
    if mode then begin
     fillchar(data,sizeof(data),0);
     blockread(f,data,16384,rsize);
     if rsize<16384 then done:=on;
     if stereo then begin
      for i:=0 to 4095 do sour[i]:=data[i*2];
      encodeFrame;
      for i:=0 to 4095 do sour[i]:=data[i*2+1];
      encodeFrame;
      inc(frames,2);
     end else begin
      for i:=0 to 4095 do sour[i]:=data[i];
      encodeFrame;
      inc(frames);
      if rsize>8192 then begin
       for i:=0 to 4095 do sour[i]:=data[i+4096];
       encodeFrame; inc(frames);
      end;
     end;
    end else begin
     blockread(f,packsize,2);
     blockread(f,pdata,packsize);
     blockread(f,d1[4095],7);
     decodeFrame; inc(frames);
     if stereo then begin
      for i:=0 to 4095 do data[i*2+1]:=dest[i];
      blockread(f,packsize,2);
      blockread(f,pdata,packsize);
      blockread(f,d1[4095],7);
      decodeFrame; inc(frames);
      for i:=0 to 4095 do data[i*2]:=dest[i];
      blockwrite(f2,data,16384);
     end else blockwrite(f2,dest,8192);
     if frames>=totalframes then done:=on;
    end;
    textcolor(15);
    gotoxy(13,wherey); clreol;
    write('[',frames,'/',totalframes,'] - ',frames/totalframes*100:3:0,'%');
   until done;
   if mode then begin
    head.frames:=frames;
    head.fsize:=filesize(f2);
    seek(f2,0); blockwrite(f2,head,sizeof(head));
    writeln;
    textcolor(10);
    writeln('Результат: ',filesize(f2) div 1024,'Kb. Сжато в ',filesize(f)/filesize(f2):3:1,' раз.');
   end;
   close(f);
   close(f2);
  end;
 procedure help;
  begin
   textcolor(10);
   writeln;
   writeln('     CoolSoft Audio Stream - это формат сжатия звуковых данных с потерями, ');
   writeln('позволяющий сжимать звуковые файлы в 5-8 раз сохраняя качество на уровне');
   writeln('ADPCM 3bit, а иногда и лучше! С помощью данной программы вы можете сжимать');
   writeln('и разжимать звуковые файлы.');
   textcolor(11);
   writeln('Преимущества:');
   textcolor(14);
   writeln('     - степень сжатия выше чем у любого ADPCM-кодера');
   writeln('     - скорость работы намного выше чем у любого кодера, основанного на');
   writeln('       спектральном разложении. Это достигнуто поскольку');
   writeln('     - использованы исключительно простые алгоритмы!');
   writeln('     - каждый стереоканал пакуется отдельно, в отличие от MP3, где это может');
   writeln('       привести к существенным искажениям стереозвука');
   textcolor(11);
   writeln('Недостатки:');
   textcolor(13);
   writeln('       Я надеюсь что вы их сами заметите если захотите :-)');
   textcolor(10); writeln;
   writeln('Формат запуска: cascodec.exe source destination ');
   textcolor(14);
   writeln('   source - имя исходного файла (либо 16-bit WAV/RAW/PCM, либо CAS)');
   writeln('   destination - имя создаваемого файла');
   textcolor(15); writeln;
   writeln(' Ну вот и все. Желаю успехов! Связаться со мной можно по адресу 2:450/91.5');
   textcolor(7);
   halt;
  end;
 begin
  textbackground(0);
  writeln; writeln; writeln;
  textcolor(15); textbackground(7); clreol;
  write('CoolSoft Audio Stream CODEC. V. 1.0 beta. Copyright (C) CoolSoft Technologies');
  textbackground(0); writeln;
  if paramcount<2 then help;
  textcolor(11);
  source;
  destination;
  run;
  textcolor(7);
 end.