tta кодек на Паскале

Планы, идеология, архитектура и т.п.

Модератор: Модераторы

tta кодек на Паскале

Сообщение Alexander » 30.09.2023 19:36:22

Переписал кодек на Паскаль для органайзера. Урезал до только 16 бит (без 8 и 24) ради скорости -- предполагалась только запись с микрофона.
Можно применять для своих программ compress('вход.wav', 'выход.tta') или переписать в лучшую версию.
В Паскале нет sar, sal, а только shl, shr. Пришлось использовать ассемблер. Возможно это мысль -- доработать Паскаль, чтобы они там были, либо приходится включать операторы Си или использовать ассемблер в таких алгоритмах.
Также не нашлось прямой замены такой конструкции (переменные в регистрах) на Си (она тоже влияет на скорость):

Код: Выделить всё
__inline void hybrid_filter (fltst *fs, int *in, int mode) {
        register int *pA = fs->dl;
        register int *pB = fs->qm;
        register int *pM = fs->dx;
        register int sum = u;


Код: Выделить всё
unit ttafunctions;
{
    Pascal port of ttacodec
    Copyright (C) 2023  Artyomov N Alexander

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>.
}
{$MODE OBJFPC}
//{$RANGECHECKS ON}
{$LONGSTRINGS ON}
{$SMARTLINK ON}
{$ASMMODE INTEL}

interface

uses ttaconst, ttaarr, ttastruct, ttavar, math, sysutils, syscall;

function compress(fin, fout : utf8string)  : boolean;

implementation

function getrealtime(const st: TSystemTime) : real; register;
begin
result := st.Hour*3600.0 + st.Minute*60.0 + st.Second + st.MilliSecond/1000.0;
end;
function getrealtime : real; register;
var
   st:TSystemTime;
begin
GetLocalTime(st);
result:=getrealtime(st);
end;

procedure UPDATE_CRC32(var x, crc : DWord); register; inline;
begin
   crc := (((crc shr o) and $00FFFFFF) xor crc32_table[(crc xor x) and $FF]);
end;
procedure UPDATE_CRC32(var x : byte; var crc : DWord); register; inline;
begin
   crc := (((crc shr o) and $00FFFFFF) xor crc32_table[(crc xor x) and $FF]);
end;
function crc32(buffer :  PByte; len : DWord) : DWord; register; inline;
var
   i : DWord;
   crc : DWord = $FFFFFFFF;
begin
for i := 0 to len-1 do begin
   UPDATE_CRC32(buffer[i], crc);
end;
Exit(crc  xor  $FFFFFFFF);
end;

procedure put_unary0; register; inline;
begin
while (bit_count >= o) do begin
   BIT_BUFFER[ibit] := Byte(bit_cache) and $FF;
   UPDATE_CRC32(BIT_BUFFER[ibit], frame_crc32);
   bit_cache :=  bit_cache shr o;
   Dec(bit_count, o);
   Inc(ibit);
end; {wend}
   Inc(bit_count);
end;
procedure put_unary(value : Word); register; inline;
begin
   while true do begin
      while (bit_count >= o) do begin
         BIT_BUFFER[ibit] := Byte(bit_cache) and $FF;
         UPDATE_CRC32(BIT_BUFFER[ibit], frame_crc32);
         bit_cache :=  bit_cache shr o;
         Dec(bit_count, o);
         Inc(ibit);
      end; {wend}
      if (value > 23)  then begin
         bit_cache := bit_cache or (bit_mask[23] shl bit_count);
         Inc(bit_count, 23);
         Dec(value, 23);
      end else begin
         bit_cache := bit_cache or (bit_mask[value] shl bit_count);
         bit_count := bit_count + value + 1;
         exit;
      end;
   if value = 0 then break;
   end; {wend};
end;

procedure put_binary(value, bits : DWord); register; inline;
begin
   while (bit_count >= o) do begin
      BIT_BUFFER[ibit] := bit_cache and $FF;
      UPDATE_CRC32(BIT_BUFFER[ibit], frame_crc32);
      bit_cache := bit_cache shr o;
      bit_count := bit_count - o;
      Inc(ibit);
   end;
   bit_cache := bit_cache or (value and bit_mask[bits]) shl bit_count;
   bit_count := bit_count + bits;
end;

function compress(fin, fout : utf8string)  :  boolean; register;
var
shift : byte;
sum, l7, l6, l5, l4 : Int64;
prev : LongInt;
num_chan, data_size, byte_size, data_len : DWord;
buffer_len, framelen, lastlen, fframes : DWord;
value : DWord;
st_size : DWord = 0;
offset : DWord = 0;
def_subchunk_size : DWord = 16;
extra_len : DWord = 0;
f : Int64;
asrc : pbyte;
adata : Plongint;
seek_table : PDWord;
tmp : LongInt;
e_t : bytebool;
res : DWord;
fsrc : Int64;
fh : Int64;
z : Int64 = 0; // siZe
a {Address} : Int64;
T : LongInt;

begin
GetLocalTime(startsystime);
starttime := getrealtime(startsystime);

Assign(fdout, fout);
FileMode := 1; ReWrite(fdout, 1);
ienc := 0; ist := 0; ibit := 0;

   // clear statistics
   output_byte_count := 0;

   // print process banner
   WriteLn(stderr, 'Encode: ' + fin);

fh := do_SysCall(2 {Open}, Int64(PChar(fin)),0 {R W old 2}); if fh < 0 then begin WriteLn(stderr, 'Error: can''t open input file'); Exit(true); end;
z  := do_SysCall(o {GET LEN}, fh,0{from begin},2{SEEK_END}); if z < sizeof(wave_hdr) then begin WriteLn(stderr, 'Error: can''t get len input file'); do_SysCall(3 {Close}, fh); Exit(true); end;
a := do_SysCall(9 {FILEMAP}, 0{from begin},z,1{PROT_},1{MAP_},fh,0{from begin file});
adata := Pointer(a);
if (a < 0) or (do_SysCall(3 {Close}, fh) < 0)  then begin WriteLn(stderr, 'Error: can''t map input file'); do_SysCall(3 {Close}, fh); Exit(true); end;

   // read WAVE header
   wave_hdr := @adata[0];
   input_byte_count := sizeof(twave_hdr);

   tta_hdr.AudioFormat := wave_hdr^.AudioFormat;

   // check for supported formats
   if (tta_hdr.AudioFormat <> WAVE_FORMAT_PCM) or (wave_hdr^.ChunkID <> RIFF_SIGN) or (wave_hdr^.Format <> WAVE_SIGN) or (wave_hdr^.Subchunk1ID <> fmt_SIGN) or (wave_hdr^.Subchunk1Size > wave_hdr^.ChunkSize) or (wave_hdr^.NumChannels = 0) or (wave_hdr^.BitsPerSample > MAX_BPS)  then begin
      WriteLn(stderr, 'File format error'); do_SysCall(3 {Close}, fh); Exit(true);
   end;

   // skip extra format bytes
   if (wave_hdr^.Subchunk1Size > def_subchunk_size) then begin
      extra_len := wave_hdr^.Subchunk1Size - def_subchunk_size;
      input_byte_count := input_byte_count + extra_len;
      WriteLn(stderr, 'Encode: skiped  extra format bytes');
   end;

   // stop unsupported chunks
   subchunk_hdr := @adata[input_byte_count div 4];
   input_byte_count := input_byte_count + sizeof(subchunk_hdr^);
   if (subchunk_hdr^.SubchunkID <> data_SIGN) then begin
      WriteLn(stderr, 'unsupported chunk');
      Halt;
   end;

   framelen := Round(FRAME_TIME * wave_hdr^.SampleRate);
   num_chan := wave_hdr^.NumChannels;
   data_size := subchunk_hdr^.SubchunkSize;
   byte_size := (wave_hdr^.BitsPerSample + 7) div o;
if byte_size <> 2 then begin
writeln(stderr, 'Unsupported byte_size');
do_SysCall(3 {Close}, fh);
Exit(true);
end;
shift := flt_set[byte_size - 1]; u := 1 shl (shift - 1);

   data_len := data_size div (byte_size * num_chan);

   lastlen := data_len mod framelen;
   fframes := data_len div framelen; if lastlen <> 0 then Inc(fframes);
   st_size := (fframes + 1);
   buffer_len := num_chan * framelen;

   tta_hdr.TTAid := TTA1_SIGN;  tta_hdr.NumChannels := wave_hdr^.NumChannels; tta_hdr.BitsPerSample := wave_hdr^.BitsPerSample;   tta_hdr.SampleRate := wave_hdr^.SampleRate; tta_hdr.DataLength := data_len; tta_hdr.CRC32 := crc32(PByte(@tta_hdr), sizeof(tta_hdr) - sizeof(longint));

   // grab some space for an encoder buffers
   GetMem(seek_table, st_size*4*4);
   GetMem(atta, num_chan*sizeof(tencoder));
   // write TTA header
   blockwrite(fdout, tta_hdr, sizeof(tta_hdr));
   if  IOResult <> 0 then begin WriteLn(stderr, 'Write file header error'); do_SysCall(3 {Close}, fh); Close(fdout); Exit(true); end
   else output_byte_count := output_byte_count + sizeof(tta_hdr);

   Dec(tta_hdr.NumChannels);

   // allocate space for a seek table
   blockwrite(fdout, seek_table[0], st_size*4);
   if  IOResult <> 0 then begin WriteLn(stderr, 'Write space for seek table error'); do_SysCall(3 {Close}, fh); Close(fdout); Exit(true); end
   else output_byte_count := output_byte_count + st_size * sizeof(dword);

    bit_count := 0; bit_cache := 0; ibit := 0; lastpos := output_byte_count; // fill_buffer_write

   for fframes := fframes - 1 downto 0 do begin
      if ((fframes = 0) and (lastlen<>0)) then begin framelen := lastlen; buffer_len := num_chan * framelen; end;
      frame_crc32 := $FFFFFFFF;
      for f := 0 to tta_hdr.NumChannels {num_chan - 1} do // encoder_init
      with atta[f] do begin filldword(fst, sizeof(Tfltst), 0);
         with rice do begin k0 := 10; k1 := k0; sum0 := 16384; sum1 := sum0; end;
         last := 0;
      end; {next f encoder_init}

      prev := 0;
      fsrc := 0; // read_wave
res :=  (buffer_len * byte_size);
if res + input_byte_count  > z then res := res - ((res + input_byte_count ) - z);
if res < 1 then break;
asrc := @adata[input_byte_count div 4];

      FOR f := 0 to res div byte_size - 1 do begin
      T := asrc[fsrc]; Inc(fsrc); T := T or (ShortInt(asrc[fsrc]) shl o); Inc(fsrc);

      // transform data
      e_t := ienc < tta_hdr.NumChannels {num_chan - 1}; if e_t then begin
      prev := ((asrc[fsrc] or (ShortInt(asrc[fsrc + 1]) shl o)) - T); Tmp :=  prev;
      end else Tmp := T - prev div 2;

      // compress stage 1: fixed order 1 prediction
      T := Tmp - LongInt(((QWord(atta[ienc].last) shl 5) - QWord(atta[ienc].last)) shr 5);
      atta[ienc].last := tmp;
// compress stage 2: adaptive hybrid filter
with atta[ienc].fst do begin
   if (error < 0) then begin
Dec(qm[0], dx[0]); Dec(qm[1], dx[1]); Dec(qm[2], dx[2]); Dec(qm[3], dx[3]); Dec(qm[4], dx[4]); Dec(qm[5], dx[5]); Dec(qm[6], dx[6]); Dec(qm[7], dx[7]);
   end;
   if (error > 0) then begin
Inc(qm[0], dx[0]); Inc(qm[1], dx[1]); Inc(qm[2], dx[2]); Inc(qm[3], dx[3]); Inc(qm[4], dx[4]); Inc(qm[5], dx[5]); Inc(qm[6], dx[6]); Inc(qm[7], dx[7]);
   end;
sum := u +  dl[0] * qm[0] + dl[1] * qm[1] + dl[2] * qm[2] + dl[3] * qm[3] +dl[4] * qm[4] + dl[5] * qm[5] + dl[6] * qm[6] + dl[7] * qm[7];
l7 := dl[7]; l6 := dl[6]; l5 := dl[5]; l4 := dl[4];
dl[0] :=dl[1]; dl[1] :=dl[2]; dl[2] :=dl[3]; dl[3] :=dl[4];
dl[6] := T - dl[7];
dl[5] := dl[6] - l6;
dl[4] := dl[5] - l5;
dl[7] := T;
asm
push rax
mov rax, l7
sar rax, 30
or rax, 1
sal rax, 2
mov l7, rax
mov rax, l6
sar rax, 30
or rax, 1
sal rax, 1
mov l6, rax
mov rax, l5
sar rax, 30
or rax, 1
sal rax, 1
mov l5, rax
mov rax, l4
sar rax, 30
or rax, 1
mov l4, rax
pop rax
end;
dx[0] :=dx[1]; dx[1] :=dx[2]; dx[2] :=dx[3]; dx[3] :=dx[4];
dx[4] := l4; dx[5] := l5; dx[6] := l6; dx[7] := l7;
asm
push rax
push rcx
mov rax, sum
mov cl, [shift]
sar rax, cl
mov l7, rax
pop rcx
pop rax
end;
T := T - l7;
error := T;
end; {w}
         if T > 0 then value := ((T shl 1)-1) else value := (-(T) shl 1);

         // encode Rice unsigned
         with atta[ienc].rice do begin
         sum0 := sum0 + value - (sum0 shr 4);
         if (value >= bit_shift[k0]) then begin
            Dec(value, bit_shift[k0]);
            put_unary(1 + (value shr k1));
            if (k1 <> 0) then put_binary((value and bit_mask[k1]), k1);
            sum1 := sum1 + value - (sum1 shr 4);
            if ((k1 > 0) and (sum1 < shift_16[k1])) then Dec(k1)
            else if (sum1 > shift_16[k1 + 1]) then Inc(k1);
         end else begin put_unary0;
            if (k0 <> 0) then put_binary((value and bit_mask[k0]), k0);
         end;
         if (k0 > 0) and (sum0 < shift_16[k0]) then Dec(k0)
         else if sum0 > shift_16[k0 + 1] then Inc(k0);
         end; {w}

         if e_t then Inc(ienc) else ienc := 0;

      end; {next f}

   while (bit_count <> 0)  do begin // seek_table[ist] := done_buffer_write; Inc(ist);
      BIT_BUFFER[ibit] := bit_cache and $FF;
      UPDATE_CRC32(BIT_BUFFER[ibit], frame_crc32);
      bit_cache := bit_cache shr o;
      if bit_count > o then bit_count := bit_count - o else bit_count := 0;
      Inc(ibit);
   end;
   frame_crc32 := frame_crc32 xor $FFFFFFFF;
   Move(frame_crc32,BIT_BUFFER[ibit], 4);
   blockwrite(fdout, BIT_BUFFER[0], ibit + sizeof(longint), tmp);
         if (IOResult <> 0) then begin
            Writeln(stderr, 'done_buffer_write error');
            Halt;
         end;
   output_byte_count := output_byte_count + tmp;
   ibit := 0;
   seek_table[ist] := output_byte_count - lastpos;
   lastpos := output_byte_count; {d b w}
   Inc(ist);

      input_byte_count := input_byte_count + byte_size * buffer_len;
   end; {if fframes}

   // update the seek table
   seek(fdout, sizeof(tta_hdr) + offset);
   if  IOResult <> 0 then begin WriteLn(stderr, 'Seek error'); do_SysCall(3 {Close}, fh); Close(fdout); Exit(true); end;

   seek_table[st_size - 1] := crc32(PByte(@seek_table[0]), (st_size - 1)*4);
   blockwrite( fdout, seek_table[0], st_size*4); // placement of seek_table in file: Ok
   if  IOResult <> 0 then begin WriteLn(stderr, 'Write seek table error'); do_SysCall(3 {Close}, fh); Close(fdout); Exit(true); end;

FreeMem(seek_table);
do_SysCall(11 {Unmap}, a,z);
FreeMem(atta);

          totaltime:=getrealtime-starttime;
          if totaltime<0 then
            totaltime:=totaltime+3600.0*24.0;
          if round(frac(totaltime)*10) >= 10 then
            totaltime:=trunc(totaltime) + 1;
          timestr:=inttostr(trunc(totaltime))+'.'+inttostr(round(frac(totaltime)*10));

   writeln(stderr, 'Encode: complete, wrote ',output_byte_count,' bytes, ratio: ',output_byte_count / (input_byte_count + 1),', time: ' + timestr);
   Exit(false);
end;

end.


Код: Выделить всё
unit ttastruct;

{
    Pascal port of ttacodec
    Copyright (C) 2023  Artyomov N Alexander

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>.
}

{$MODE OBJFPC}

interface

uses ttaconst;

type
Tadapt = packed record
   k0 : dword;
   k1 : dword;
   sum0 : dword;
   sum1 : dword;
end;
padapt = ^tadapt;

Tfltst = packed record
   error : longint;
   qm : array[0..8] of longint;
   dx : array[0..8] of longint;
   dl : array[0..7] of longint;
end;
pfltst = ^tfltst;

Tencoder = packed record
   fst : Tfltst;
   rice : Tadapt;
   last : longint;
end;
pencoder = ^tencoder;

Ttta_hdr = packed record
   TTAid : dword;
   AudioFormat : word;
   NumChannels : word;
   BitsPerSample : word;
   SampleRate : dword;
   DataLength : dword;
   CRC32 : dword;
end;

Twave_hdr = packed record
   ChunkID : dword;
   ChunkSize : dword;
   Format : dword;
   Subchunk1ID : dword;
   Subchunk1Size : dword;
   AudioFormat : word;
   NumChannels : word;
   SampleRate : dword;
   ByteRate : dword;
   BlockAlign : word;
   BitsPerSample : word;
end;
pwave_hdr = ^twave_hdr;

Tsubchunk_hdr = packed record
   SubchunkID : dword;
   SubchunkSize : dword;
end;
psubchunk_hdr = ^Tsubchunk_hdr;

implementation

end.


Код: Выделить всё
unit ttavar;

{
    Pascal port of ttacodec
    Copyright (C) 2023  Artyomov N Alexander

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>.
}

{$MODE OBJFPC}
{$LONGSTRINGS ON}

interface

uses ttastruct, ttaconst, ttaarr, sysutils;

var

u : longint;

input_byte_count : QWord;
output_byte_count : QWord;

wave_hdr : pwave_hdr;
subchunk_hdr : psubchunk_hdr;
tta_hdr : Ttta_hdr;

BIT_BUFFER :  array[0..BIT_BUFFER_SIZE + 8 - 1] of byte;

frame_crc32 : DWord;
bit_count : LongInt = 0;
bit_cache : LongInt;
lastpos : DWord;

shift_16 : PLongInt = @bit_shift;

encoder : tencoder;

atta : pencoder;
ienc, ist, ibit : Int64;

fdout : file;

starttime  : real;
startsystime : TSystemTime;
totaltime : real;
timestr    : string[20];

implementation

initialization
shift_16 := shift_16 + 4;
end.


Код: Выделить всё
unit ttaarr;

{
    Pascal port of ttacodec
    Copyright (C) 2023  Artyomov N Alexander

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>.
}

{$MODE OBJFPC}

interface

const
  crc32_table : array[0..255] of dword = (
    $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f,
    $e963a535, $9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988,
    $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, $1db71064, $6ab020f2,
    $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
    $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9,
    $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, $a2677172,
    $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c,
    $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
    $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423,
    $cfba9599, $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924,
    $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, $01db7106,
    $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
    $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d,
    $91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e,
    $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950,
    $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
    $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7,
    $a4d1c46d, $d3d6f4fb, $4369e96a, $346ed9fc, $ad678846, $da60b8d0,
    $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa,
    $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
    $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81,
    $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a,
    $ead54739, $9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84,
    $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
    $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb,
    $196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, $67dd4acc,
    $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8, $a1d1937e,
    $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
    $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55,
    $316e8eef, $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236,
    $cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, $b2bd0b28,
    $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
    $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f,
    $72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38,
    $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
    $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
    $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69,
    $616bffd3, $166ccf45, $a00ae278, $d70dd2ee, $4e048354, $3903b3c2,
    $a7672661, $d06016f7, $4969474d, $3e6e77db, $aed16a4a, $d9d65adc,
    $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
    $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693,
    $54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,
    $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d );

  bit_mask : array[0..32] of dword = (
    $00000000, $00000001, $00000003, $00000007, $0000000f, $0000001f,
    $0000003f, $0000007f, $000000ff, $000001ff, $000003ff, $000007ff,
    $00000fff, $00001fff, $00003fff, $00007fff, $0000ffff, $0001ffff,
    $0003ffff, $0007ffff, $000fffff, $001fffff, $003fffff, $007fffff,
    $00ffffff, $01ffffff, $03ffffff, $07ffffff, $0fffffff, $1fffffff,
    $3fffffff, $7fffffff, $ffffffff );

  bit_shift : array[0..39] of dword = (
    $00000001, $00000002, $00000004, $00000008, $00000010, $00000020,
    $00000040, $00000080, $00000100, $00000200, $00000400, $00000800,
    $00001000, $00002000, $00004000, $00008000, $00010000, $00020000,
    $00040000, $00080000, $00100000, $00200000, $00400000, $00800000,
    $01000000, $02000000, $04000000, $08000000, $10000000, $20000000,
    $40000000, $80000000, $80000000, $80000000, $80000000, $80000000,
    $80000000, $80000000, $80000000, $80000000 );

flt_set :  array[0..2] of longint = ( 10, 9, 10 );

implementation


end.


Код: Выделить всё
unit ttaconst;

{
    Pascal port of ttacodec (http://tta.sourceforge.net)
    Copyright (C) 2023  Artyomov N Alexander

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>.
}

{$MODE OBJFPC}

interface

const
   MAX_BPS = 16;   
   FRAME_TIME = 1.04489795918367346939;   
   TTA1_SIGN = $31415454;   
   RIFF_SIGN = $46464952;   
   WAVE_SIGN = $45564157;   
   fmt_SIGN = $20746D66;   
   data_SIGN = $61746164;   
   MAX_ORDER = 16;   
   BIT_BUFFER_SIZE = 1024*1024;   
   WAVE_FORMAT_PCM = 1;   
   WAVE_FORMAT_EXTENSIBLE = $FFFE;   
   o = 8;

implementation


end.
Аватара пользователя
Alexander
энтузиаст
 
Сообщения: 689
Зарегистрирован: 18.12.2005 19:10:00
Откуда: оттуда

Re: tta кодек на Паскале

Сообщение runewalsh » 04.10.2023 21:59:09

Alexander писал(а):В Паскале нет sar, sal, а только shl, shr.

Есть! А если бы и не было, можно было бы какой-нибудь не очень сильно медленный прикол придумать, типа
Код: Выделить всё
function Sar(x, by: int32): int32;
begin
   result := int32(x shr by or -(x shr (bitsizeof(x) - 1)) shl (bitsizeof(x) - 1 - by));
end;
Аватара пользователя
runewalsh
энтузиаст
 
Сообщения: 578
Зарегистрирован: 27.04.2010 00:15:25

Re: tta кодек на Паскале

Сообщение Дож » 05.10.2023 08:41:36

Также не нашлось прямой замены такой конструкции (переменные в регистрах)


Можно воспользоваться тем, что параметры функций передаются в регистрах:

Код: Выделить всё
procedure hybrid_filter(fs: Pflst; in_arr: PInt32; mode: Int32);
  procedure process_fast(pA, pB, pM: PInt32; var sum: Int32); inline;
  begin
    Dec(pB^, pM^);
    Inc(sum, pA^ * pB^);
    Inc(pA);
    Dec(pB);
    Inc(pM);
  end;
var
  sum: Int32;
begin
  process_fast(fs^.dl, fs^.qm, fs^.dx, sum);
end;


# Var pA located in register rax
# Var pB located in register r8
# Var pM located in register r9
# Var sum located in register rdx


Код: Выделить всё
# [19] process_fast(fs^.dl, fs^.qm, fs^.dx, sum);
   movq   16(%rcx),%rdx
   movq   8(%rcx),%rcx
   movq   (%rax),%rax
   movl   (%rdx),%r8d
   subl   %r8d,(%rcx)
   movl   (%rax),%r8d
   imull   (%rcx),%r8d
   addl   %r8d,(%rsp)
   addq   $4,%rax
   subq   $4,%rcx
   addq   $4,%rdx
Аватара пользователя
Дож
энтузиаст
 
Сообщения: 899
Зарегистрирован: 12.10.2008 16:14:47

Re: tta кодек на Паскале

Сообщение Alexander » 05.10.2023 09:05:33

> Есть!

А SalLongint тоже есть ? Не увидел. Или SarLongint может и SalLongint при отрицательных числах смещения ?
В документации про shr/shl сказано, что нет замены сишным >> <<, либо это нужно дополнить там в документацию: https://wiki.freepascal.org/Shr. Иначе создаётся такое ощущение.

> не очень сильно медленный прикол придумать, типа
Для кроссплатформенноти всё может быть. Но всё равно некоторые потери в скорости будут.

> Можно воспользоваться тем, что параметры функций передаются в регистрах:

Красивое решение.
Аватара пользователя
Alexander
энтузиаст
 
Сообщения: 689
Зарегистрирован: 18.12.2005 19:10:00
Откуда: оттуда

Re: tta кодек на Паскале

Сообщение Дож » 05.10.2023 09:55:57

А SalLongint тоже есть ?

shl (логический сдвиг влево) и sal (арифметический сдвиг влево) -- это одна и та же операция, поэтому SalLongint и не особо нужен.
Аватара пользователя
Дож
энтузиаст
 
Сообщения: 899
Зарегистрирован: 12.10.2008 16:14:47

Re: tta кодек на Паскале

Сообщение Alexander » 05.10.2023 17:40:51

Так и сделал, спасибо ! А sal тогда так и останется с ассемблером.

Тогда следующий ряд вопросов.
1. В Tfltst у массивов qm и dx максимальное значение индекса 8. Если я ставлю необходимое 7 -- работает, но медленнее. Это что-то вроде внутреннего выравнивания записи получается ? Нет ли и на этот счёт более красивого решения ? Опция packed на это никак не влияет, а между 7 и 8 разница есть.

2. Интересен ли сам кодек в таком виде или некоторое его развитие ? И интересны ли функции из оригинального в части битности и всяких id3 тэгов в wav, которые при ускорении кодека убыли ? Нужна ли декомпрессия и проверка ? В общем как бы он мог выглядеть в итоге на Паскале ? Что нужно и что нет. Оригинальный тоже не "всеяден", часть вариантов (форматов, ошибок, аномалий) входных файлов не умеет принимать, который умеет тот же flac. Но для указанной задачи он уже хорош, а любое дополнение может привести к замедлению.

3. Разбиение по файлам. По начальным технологичным причинам я его разбил на файлы так, теперь это не важно. Может разбить или соединить иначе ?
Аватара пользователя
Alexander
энтузиаст
 
Сообщения: 689
Зарегистрирован: 18.12.2005 19:10:00
Откуда: оттуда

Re: tta кодек на Паскале

Сообщение bormant » 07.11.2023 14:48:30

Alexander писал(а):1. В Tfltst у массивов qm и dx максимальное значение индекса 8. Если я ставлю необходимое 7 -- работает, но медленнее.

А так тоже медленнее?
Код: Выделить всё
Tfltst = record
   qm,
   dx,
   dl: array [0..7] of Longint;
   error: Longint;
end;
Аватара пользователя
bormant
постоялец
 
Сообщения: 407
Зарегистрирован: 21.03.2012 11:26:01

Re: tta кодек на Паскале

Сообщение Alexander » 07.11.2023 16:52:10

Да, медленнее. На тестовом файле 2,9 секунды с 8 и 3.0 секунды со всеми семёрками.
Аватара пользователя
Alexander
энтузиаст
 
Сообщения: 689
Зарегистрирован: 18.12.2005 19:10:00
Откуда: оттуда

Re: tta кодек на Паскале

Сообщение bormant » 07.11.2023 18:29:41

Alexander писал(а):На тестовом файле 2,9 секунды с 8 и 3.0 секунды со всеми семёрками.

Могу попросить описание методики тестирования, максимально подробное с целью воспроизведения? Можно приватно на bormant (at) mail dot ru.
Отдельно прошу указать, на чем получены Ваши результаты тестирования.

Заранее прошу извинения за всевозможные причины того для.
Аватара пользователя
bormant
постоялец
 
Сообщения: 407
Зарегистрирован: 21.03.2012 11:26:01

Re: tta кодек на Паскале

Сообщение Alexander » 07.11.2023 19:20:44

http://soft.self-made-free.ru/ttatest.txz

Метод такой. Комментируется одна декларация записи Tfltst, раскомментируется другая.
Тест собирается:
fpc tstf.pas
И запускается:
./tstf split-track05.wav split-track05..tta
Встроенный контроль времени покажет время.
Затем комментируется вторая декларация, и раскомментируется первая,
компилируется и повторяется та же проверка на том же файле данных.
Результаты сравниваются.

Код: Выделить всё
cpu-info
Packages:
        0: AMD Athlon II X2 255
Microarchitectures:
        2x K10
Cores:
        0: 1 processor (0), AMD K10
        1: 1 processor (1), AMD K10
Logical processors (System ID):
        0 (0): APIC ID 0x00000000
        1 (1): APIC ID 0x00000001


Код: Выделить всё
uname -a
Linux my 6.6.0 #1 SMP PREEMPT_DYNAMIC Mon Oct 30 15:07:55 MSK 2023 x86_64 GNU/Linux
Аватара пользователя
Alexander
энтузиаст
 
Сообщения: 689
Зарегистрирован: 18.12.2005 19:10:00
Откуда: оттуда


Вернуться в Разработки на нашем сайте

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 2

Рейтинг@Mail.ru