arith.pas

多种算法压缩与解压缩方式

      table^.links[i].next := temp_ptr;
    end;
    index := i;
  end;
  // the switch has been performed. now I can update the counts
  inc(table^.stats[index].counts);
  if (table^.stats[index].counts = 255) then
    rescale_table(table);
end;

function convert_int_to_symbol(c:integer;var  s:TSYMBOL):integer;
var
  i:integer;
  table:PCONTEXT;
begin
  table := contexts[current_order];
  totalize_table(table);
  s.scale := totals[0];
  if (current_order = -2) then
    c := -c;
  for i := 0 to  table.max_index do
  begin
    if (c = integer(table.stats[i].symbol)) then
    begin
      if (table.stats[i].counts = 0) then
         break;
      s.low_count := totals[i+2];
      s.high_count := totals[i+1];
      result:=0;
      exit;
    end;
  end;
  s.low_count := totals[1];
  s.high_count := totals[0];
  dec(current_order);
  result:=1;
end;

procedure get_symbol_scale( var s:TSYMBOL);
var
  table:PCONTEXT;
begin
  table := contexts[current_order];
  totalize_table(table);
  s.scale := totals[0];
end;

function convert_symbol_to_int(count:integer;var s:TSYMBOL):integer;
var
  c:integer;
  table:PCONTEXT;
begin
  table := contexts[current_order];
  c:=0;
  while count < totals[c] do inc(c);
  s.high_count := totals[c - 1];
  s.low_count := totals[c];
  if (c = 1) then
  begin
    dec(current_order);
    result:=ESCAPE;
    exit;
  end;
  if (current_order < -1) then
    result:= -table.stats[c - 2].symbol
  else
    result:=table.stats[c - 2].symbol;
end;

procedure add_character_to_model(  c:integer );
var
  i:integer;
begin
  if (max_order < 0) or (c < 0) then exit;
  contexts[max_order] :=
    shift_to_next_context(contexts[max_order], c, max_order);
  for i := max_order - 1 downto 1 do
    contexts[i] := contexts[i + 1].lesser_context;
end;

function shift_to_next_context(table:PCONTEXT; c, order:integer):PCONTEXT;
var
  i:integer;
  new_lesser:PCONTEXT;
begin

	// first, try to find the new context by backing up the lesser
	// context and searching its link table. if I find the link, we take
	// a quick and easy exit, returning the link. note that their is a 
	// special Kludge for context order 0. we hnow for a fact that 
	// that lesser context pointer at order 0 points to the null table.
	// order -1, and we know that the -1 table only has a single link
	// pointer. which points back to the order 0 table.
  table := table.lesser_context;
  if (order = 0) then
  begin
    result:= table.links[0].next;
    exit;
  end;
  for i:=0 to table.max_index do
    if (table.stats[i].symbol = byte(c) ) then
      if (table.links[i].next <> nil) then
      begin
        result:=table.links[i].next;
        exit;
      end else
        break;

	// if I get here, it means the new context did not exist. I have to 
	// create the new context, add a link to it here, and add the backwards
	// link to *his* previous context. Creating the table and adding it to
	// this table is pretty easy. but adding the back pointer isn't. Since
	// creating the new back pointer isn't easy, I duck my responsibility
	// and recurse to myself in order to pick it up.
  new_lesser := shift_to_next_context(table, c, order - 1);

	// Now that I have the back pointer for this table, I can make a call
	// to a utility to allocate the new table
  table := allocate_next_order_table(table, c, new_lesser);
  result:=table;
end;

// rexdaling the table needs to be done for one of three reasons.
// first, if the maximum count for the table has exceeded 16383, it 
// means that arithmetic coding using 16 and 32 bit registers might
// no longer work. secondly, if an individual symbol count has
// reached 255, it will no longer fit in a byte. third, if the
// current model isn't compressing well, the compressor program may 
// want to rescale all tables in order to give more weight to newer
// statistics.
// all this routine does is divide each count by 2. if any counts
// drop to 0, the counters can be removed from the stats table, but 
// only if this is a leaf context. Otherwise, we might cut a link to 
// a higher order table.
procedure rescale_table(table:PCONTEXT);
var
  i:integer;
begin
  if ( table.max_index = -1) then exit;
  for i:=0 to table.max_index do
    table.stats[i].counts := table.stats[i].counts div 2;
  if (table.stats[table.max_index].counts = 0) and
     (table.links =nil) then
  begin
    while (table.stats[table.max_index].counts = 0) and
          (table.max_index >= 0) do
      dec(table.max_index);
    if (table.max_index = -1) then
    begin
      freemem(table.stats);
      table.stats := nil;
    end else
    begin
      ReallocMem(table.stats,sizeof(STATS)*(table.max_index + 1));
    end;
  end;
end;

// this routine has the job of creating a cumulative totals table for
// a given context. the cumulative low and high for symbol c are going to 
// be shored in totals[c + 2] and totals[c + 1]. Locations 0 and 1 are 
// reserved for the special ESCAPE symbol.
procedure totalize_table(table:PCONTEXT);
var
  i:integer;
  max:byte;
begin
  while true do
  begin
    max := 0;
    i := table.max_index + 2;
    totals[i] := 0;
    while i>1 do
    begin
      totals[i - 1] := totals[i];
      if (table.stats[i - 2].counts<>0) then
        if ((current_order = -2) or
          (scoreboard[table.stats[i - 2].symbol] = #0)) then
            totals[i - 1] :=  totals[i - 1]+ table.stats[i - 2].counts;
      if (table.stats[i - 2].counts > max) then
        max := table.stats[i - 2].counts;
      dec(i);
    end;
    // here is where the escape calulation needs to take place.
    if  (max = 0) then
      totals[0] := 1
    else
    begin
      totals[0] := 256 - table.max_index;
      totals[0] :=totals[0]*(table.max_index);
      totals[0] := totals[0] div 256;
      totals[0] := totals[0] div max;
      inc(totals[0]);
      totals[0] :=totals[0]+ totals[1];
    end;
    if (totals[0] < MAXIMUM_SCALE) then
      break;
    rescale_table(table);
  end;
  for i:=0 to   table.max_index-1 do         //  应为table.max_index ?????
    if (table.stats[i].counts <> 0) then
      scoreboard[table.stats[i].symbol] := #1;
end;

procedure recursive_flush( table:PCONTEXT );
var
  i:integer;
begin
  if (table.links <> nil) then
    for i:=0 to  table.max_index do
      if (table.links[i].next <> nil) then
        recursive_flush(table.links[i].next);
  rescale_table(table);
end;

procedure flush_model();
begin
//  putc('F', stdout);
  recursive_flush(contexts[0]);
end;


//---------------------------------------------------------------
// everything from here down define the arithmetic coder section
// of the program
var
  code,             // the present input code value
  low,              // start of the current code range
  high:word;        // end of the current code range
  underflow_bits:Dword;	// number of underflow bits pending

procedure initialize_arithmetic_encoder();
begin
  low := 0;
  high := $ffff;
  underflow_bits := 0;
end;

procedure OutputBit( bit_file:Pbit_file;bit:integer);
begin
  if (bit<>0) then
    bit_file.rack := bit_file.rack or bit_file.mask;
  bit_file.mask :=bit_file.mask shr 1;
  if (bit_file.mask = 0) then
  begin
    putc(bit_file.rack, bit_file.Afile);
    inc(bit_file.pacifier_counter);
    bit_file.rack := 0;
    bit_file.mask := $80;

//		if (putc(bit_file->rack, bit_file->file) != bit_file->rack)
//			fatal_error("Fatal error in OutputBit!\n");
//		else if ((bit_file->pacifier_counter++ & PACIFIER_COUNT) == 0)
//			putc('.', stdout);
//		bit_file->rack = 0;
//		bit_file->mask = 0x80;
  end;
end;
procedure OutputBits( bit_file:Pbit_file;code:Dword; count:integer);
var
  mask:Dword;
begin
  mask := 1;
  mask:=mask shl (count - 1);
  while (mask <> 0) do
  begin
    if (mask and code)<>0 then
      bit_file^.rack :=bit_file^.rack or bit_file^.mask;
    bit_file^.mask :=bit_file^.mask shr 1;
    if (bit_file^.mask = 0) then
    begin
      putc(bit_file^.rack, bit_file^.Afile);
      inc(bit_file^.pacifier_counter);
      bit_file^.rack := 0;
      bit_file^.mask := $80;
    end;
    mask :=mask shr 1;
  end;
end;


function InputBit(bit_file:Pbit_file):integer;
var
  value:integer;
begin
  if (bit_file.mask = $80) then
  begin
    bit_file.rack := getc(bit_file.Afile);
    if (bit_file.rack = EOF) then
      raise exception.Create('Fatal error in InputBit!');
    inc(bit_file.pacifier_counter);
//         if ((bit_file->pacifier_counter++ & PACIFIER_COUNT) == 0)
//                          putc('.', stdout);
  end;
  value := bit_file.rack and bit_file.mask;
  bit_file.mask :=bit_file.mask shr 1;
  if (bit_file.mask = 0) then   bit_file.mask := $80;
  if value>0 then result:=1 else result:=0;
end;
(*
unsigned long InputBits( BIT_FILE* bit_file, int bit_count )
{
	unsigned long mask;
	unsigned long return_value;

	mask = 1L << (bit_count - 1);
	return_value = 0;
	while (mask != 0)
	{
		if (bit_file->mask == 0x80)
		{
			bit_file->rack = getc(bit_file->file);
			if (bit_file->rack == EOF)
				fatal_error("Fatal error in InputBit!\n");
			if ((bit_file->pacifier_counter++ & PACIFIER_COUNT) == 0)
					putc('.', stdout);
		}
		if (bit_file->rack & bit_file->mask)
			return_value |= mask;
		mask >>= 1;
		bit_file->mask >>= 1;
		if (bit_file->mask == 0)
			bit_file->mask = 0x80;
	}
	return return_value;
}
*)

procedure flush_arithmetic_encoder(stream:Pbit_file);
begin
  OutputBit(stream, low and $4000 );
  inc(underflow_bits);
  while( underflow_bits > 0 ) do
  begin
    OutputBit( stream, not low and $4000 );
    dec(underflow_bits);
  end;
  OutputBits( stream, 0, 16 );
end;

procedure encode_symbol(stream:Pbit_file;var s:TSYMBOL);
var
  range:integer;

begin

  // these three lines rescale high and low for the new symbol.
  range := (high - low) + 1;
  high := low +  ((range * s.high_count) div s.scale - 1);
  low := low +  ((range * s.low_count) div s.scale);

  // this loop turns out new bits until high and low are far enough
  // apart to have stabilized.
  while true do
  begin
    // if this test passer, it means that the MSDigits match, and can
    // be sent to the output stream.
    if ((high and $8000) = (low and $8000)) then
    begin
      OutputBit( stream, high and $8000 );
      while ( underflow_bits > 0 ) do
      begin
        OutputBit( stream, not high and $8000);
        dec(underflow_bits);
      end;
    end
    // if this test passes, the n  are in danger of underflow, because
    // the MSDigits don't match, and the 2nd digits are just one apart.
    else if ((low and $4000) and not (high and $4000))>0 then
    begin
      underflow_bits :=underflow_bits + 1;
      low := low and $3fff;
      high := high or $4000;
    end else
      exit;
    low :=  low shl  1;
    high := high shl 1;
    high := high or 1;
  end;
end;

function get_current_count(var s:TSYMBOL):smallint;
var
  range:integer;
begin
  range := (high - low) + 1;
  result:= (((( code - low ) + 1) * s.scale - 1) div range);
end;

procedure initialize_arithmetic_decoder( stream:Pbit_file );
var
  i:integer;
begin
  code := 0;
  for i:=0 to 15 do
  begin
    code :=code shl 1;
    code :=code + InputBit(stream);
  end;
  low := 0;
  high := $ffff;
end;

procedure remove_symbol_from_stream( stream:Pbit_file;var s:TSYMBOL);
var
  range:Dword;
begin
  // first, the range is expanded to account for the symbol removal
  range := (high - low) + 1;
  high := low + ((range * s.high_count) div s.scale - 1);
  low := low +  ((range * s.low_count) div  s.scale);
  // next, any possible bits are shipped out
  while true do
  begin
    // if the MSDigits match, the ibts will be shifted out.
    if ((high and $8000) = (low and $8000)) then
    begin

    end
    // else, if underflow is threatening, shift out the 2nd MSDigit.
    else if ((low and $4000) = $4000) and ((high and $4000) = 0) then
    begin
      code := code xor $4000;
      low := low and $3fff;
      high :=high or $4000;
    end
    // otherwise, nothing can be shifted out, so I return.
    else
      exit;
    low :=low shl 1;
    high :=high shl 1;
    high :=high or 1;
    code :=code shl 1;
    code :=code+ InputBit(stream);
  end;
end;


end.