graphiccompression.pas

graphicex 增加对各种图形格式的支持

      RunLength := Pixel and $7F;
      if RunLength = 0 then Break;

      if (Pixel and $80) <> 0 then
      begin
        Move(Source8^, Target8^, RunLength);
        Inc(Target8, RunLength);
        Inc(Source8, RunLength);
      end
      else
      begin
        Pixel := Source8^;
        Inc(Source8);
        FillChar(Target8^, RunLength, Pixel);
        Inc(Target8, RunLength);
      end;
    end;
  end
  else
  begin
    // 16 bits per sample
    Source16 := Source;
    Target16 := Dest;
    while True do
    begin
      // SGI images are stored in big endian style, swap this one repeater value for it
      Pixel16 := Swap(Source16^);
      Inc(Source16);
      RunLength := Pixel16 and $7F;
      if RunLength = 0 then Break;

      if (Pixel16 and $80) <> 0 then
      begin
        Move(Source16^, Target16^, 2 * RunLength);
        Inc(Source16^, RunLength);
        Inc(Target16^, RunLength);
      end
      else
      begin
        Pixel16 := Source16^;
        Inc(Source16);
        while RunLength > 0 do
        begin
          Target16^ := Pixel16;
          Inc(Target16);
          Dec(RunLength);
        end;
      end;
    end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TSGIRLEDecoder.Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal);

begin

end;

//----------------- TCUTRLE --------------------------------------------------------------------------------------------

procedure TCUTRLEDecoder.Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer);

var
  TargetPtr: PByte;
  Pixel: Byte;
  RunLength: Cardinal;

begin
  TargetPtr := Dest;
  // skip first two bytes per row (I don't know their meaning)
  Inc(PByte(Source), 2);
  while True do
  begin
    Pixel := PByte(Source)^;
    Inc(PByte(Source));
    if Pixel = 0 then Break;

    RunLength := Pixel and $7F;
    if (Pixel and $80) = 0 then
    begin
      Move(Source^, TargetPtr^, RunLength);
      Inc(TargetPtr, RunLength);
      Inc(PByte(Source), RunLength);
    end
    else
    begin
      Pixel := PByte(Source)^;
      Inc(PByte(Source));
      FillChar(TargetPtr^, RunLength, Pixel);
      Inc(TargetPtr, RunLength);
    end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TCUTRLEDecoder.Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal);

begin

end;

//----------------- TPSPRLEDecoder -------------------------------------------------------------------------------------

procedure TPSPRLEDecoder.Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer);

var
  SourcePtr,
  TargetPtr: PByte;
  RunLength: Cardinal;

begin
  SourcePtr := Source;
  TargetPtr := Dest;
  while PackedSize > 0 do
  begin
    RunLength := SourcePtr^;
    Inc(SourcePtr);
    Dec(PackedSize);
    if RunLength < 128 then
    begin
      Move(SourcePtr^, TargetPtr^, RunLength);
      Inc(TargetPtr, RunLength);
      Inc(SourcePtr, RunLength);
      Dec(PackedSize, RunLength);
    end
    else
    begin
      Dec(RunLength, 128);
      FillChar(TargetPtr^, RunLength, SourcePtr^);
      Inc(SourcePtr);
      Inc(TargetPtr, RunLength);
      Dec(PackedSize);
    end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TPSPRLEDecoder.Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal);

begin

end;

//----------------- TGIFLZWDecoder -------------------------------------------------------------------------------------

{$ifdef UseLZW}

constructor TGIFLZWDecoder.Create(InitialCodeSize: Byte);

begin
  FInitialCodeSize := InitialCodeSize;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGIFLZWDecoder.Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer);

var
  I: Integer;
  Data,           // current data
  Bits,           // counter for bit management
  Code: Cardinal; // current code value
  SourcePtr: PByte;
  InCode: Cardinal; // Buffer for passed code

  CodeSize: Cardinal;
  CodeMask: Cardinal;
  FreeCode: Cardinal;
  OldCode: Cardinal;
  Prefix: array[0..4095] of Cardinal; // LZW prefix
  Suffix,                             // LZW suffix
  Stack: array [0..4095] of Byte;     // stack
  StackPointer: PByte;
  Target: PByte;
  FirstChar: Byte;  // Buffer for decoded byte
  ClearCode,
  EOICode: Word;

begin
  Target := Dest;
  SourcePtr := Source;

  // initialize parameter
  CodeSize := FInitialCodeSize + 1;
  ClearCode := 1 shl FInitialCodeSize;
  EOICode := ClearCode + 1;
  FreeCode := ClearCode + 2;
  OldCode := NoLZWCode;
  CodeMask := (1 shl CodeSize) - 1;

  // init code table
  for I := 0 to ClearCode - 1 do
  begin
    Prefix[I] := NoLZWCode;
    Suffix[I] := I;
  end;

  // initialize stack
  StackPointer := @Stack;
  FirstChar := 0;

  Data := 0;
  Bits := 0;
  while (UnpackedSize > 0) and (PackedSize > 0) do
  begin
    // read code from bit stream
    Inc(Data, SourcePtr^ shl Bits);
    Inc(Bits, 8);
    while Bits >= CodeSize do
    begin
      // current code
      Code := Data and CodeMask;
      // prepare next run
      Data := Data shr CodeSize;
      Dec(Bits, CodeSize);

      // decoding finished?
      if Code = EOICode then Break;

      // handling of clear codes
      if Code = ClearCode then
      begin
        // reset of all variables
        CodeSize := FInitialCodeSize + 1;
        CodeMask := (1 shl CodeSize) - 1;
        FreeCode := ClearCode + 2;
        OldCode := NoLZWCode;
        Continue;
      end;

      // check whether it is a valid, already registered code
      if Code > FreeCode then Break;

      // handling for the first LZW code: print and keep it
      if OldCode = NoLZWCode then
      begin
        FirstChar := Suffix[Code];
        Target^ := FirstChar;
        Inc(Target);
        Dec(UnpackedSize);
        OldCode := Code;
        Continue;
      end;

      // keep the passed LZW code
      InCode := Code;  

      // the first LZW code is always smaller than FFirstCode
      if Code = FreeCode then
      begin
        StackPointer^ := FirstChar;
        Inc(StackPointer);
        Code := OldCode;
      end;

      // loop to put decoded bytes onto the stack
      while Code > ClearCode do
      begin
        StackPointer^ := Suffix[Code];
        Inc(StackPointer);
        Code := Prefix[Code];
      end;

      // place new code into code table
      FirstChar := Suffix[Code];
      StackPointer^ := FirstChar;
      Inc(StackPointer);
      Prefix[FreeCode] := OldCode;
      Suffix[FreeCode] := FirstChar;

      // increase code size if necessary
      if (FreeCode = CodeMask) and
         (CodeSize < 12) then
      begin
        Inc(CodeSize);
        CodeMask := (1 shl CodeSize) - 1;
      end;
      if FreeCode < 4095 then Inc(FreeCode);

      // put decoded bytes (from the stack) into the target Buffer
      OldCode := InCode;
      repeat
        Dec(StackPointer);
        Target^ := StackPointer^;
        Inc(Target);
        Dec(UnpackedSize);
      until StackPointer = @Stack;
    end;
    Inc(SourcePtr);
    Dec(PackedSize);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TGIFLZWDecoder.Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal);

begin

end;

{$endif}

//----------------- TRLADecoder ----------------------------------------------------------------------------------------

procedure TRLADecoder.Decode(var Source, Dest: Pointer; PackedSize, UnpackedSize: Integer);

// decodes a simple run-length encoded strip of size PackedSize
// this is very similar to TPackbitsRLEDecoder

var
  SourcePtr,
  TargetPtr: PByte;
  N: SmallInt;

begin
  TargetPtr := Dest;
  SourcePtr := Source;
  while PackedSize > 0 do
  begin
    N := ShortInt(SourcePtr^);
    Inc(SourcePtr);
    Dec(PackedSize);
    if N >= 0 then // replicate next Byte N + 1 times
    begin
      FillChar(TargetPtr^, N + 1, SourcePtr^);
      Inc(TargetPtr, N + 1);
      Inc(SourcePtr);
      Dec(PackedSize);
    end
    else
    begin // copy next -N bytes literally
      Move(SourcePtr^, TargetPtr^, -N);
      Inc(TargetPtr, -N);
      Inc(SourcePtr, -N);
      Inc(PackedSize, N);
    end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TRLADecoder.Encode(Source, Dest: Pointer; Count: Cardinal; var BytesStored: Cardinal);

begin

end;

//----------------- TCCITTDecoder --------------------------------------------------------------------------------------

constructor TCCITTDecoder.Create(Options: Integer; SwapBits, WordAligned: Boolean; Width: Cardinal);

begin
  FOptions := Options;
  FSwapBits := SwapBits;
  FWidth := Width;
  FWordAligned := WordAligned;
  MakeStates;
end;

//----------------------------------------------------------------------------------------------------------------------

const
  // 256 bytes to make bit reversing easy,
  // this is actually not much more than writing bit manipulation code, but much faster
  ReverseTable: array[0..255] of Byte = (
    $00, $80, $40, $C0, $20, $A0, $60, $E0,
    $10, $90, $50, $D0, $30, $B0, $70, $F0,
    $08, $88, $48, $C8, $28, $A8, $68, $E8,
    $18, $98, $58, $D8, $38, $B8, $78, $F8,
    $04, $84, $44, $C4, $24, $A4, $64, $E4,
    $14, $94, $54, $D4, $34, $B4, $74, $F4,
    $0C, $8C, $4C, $CC, $2C, $AC, $6C, $EC,
    $1C, $9C, $5C, $DC, $3C, $BC, $7C, $FC,
    $02, $82, $42, $C2, $22, $A2, $62, $E2,
    $12, $92, $52, $D2, $32, $B2, $72, $F2,
    $0A, $8A, $4A, $CA, $2A, $AA, $6A, $EA,
    $1A, $9A, $5A, $DA, $3A, $BA, $7A, $FA,
    $06, $86, $46, $C6, $26, $A6, $66, $E6,
    $16, $96, $56, $D6, $36, $B6, $76, $F6,
    $0E, $8E, $4E, $CE, $2E, $AE, $6E, $EE,
    $1E, $9E, $5E, $DE, $3E, $BE, $7E, $FE,
    $01, $81, $41, $C1, $21, $A1, $61, $E1,
    $11, $91, $51, $D1, $31, $B1, $71, $F1,
    $09, $89, $49, $C9, $29, $A9, $69, $E9,
    $19, $99, $59, $D9, $39, $B9, $79, $F9,
    $05, $85, $45, $C5, $25, $A5, $65, $E5,
    $15, $95, $55, $D5, $35, $B5, $75, $F5,
    $0D, $8D, $4D, $CD, $2D, $AD, $6D, $ED,
    $1D, $9D, $5D, $DD, $3D, $BD, $7D, $FD,
    $03, $83, $43, $C3, $23, $A3, $63, $E3,
    $13, $93, $53, $D3, $33, $B3, $73, $F3,
    $0B, $8B, $4B, $CB, $2B, $AB, $6B, $EB,
    $1B, $9B, $5B, $DB, $3B, $BB, $7B, $FB,
    $07, $87, $47, $C7, $27, $A7, $67, $E7,
    $17, $97, $57, $D7, $37, $B7, $77, $F7,
    $0F, $8F, $4F, $CF, $2F, $AF, $6F, $EF,
    $1F, $9F, $5F, $DF, $3F, $BF, $7F, $FF
  );

  G3_EOL = -1;
  G3_INVALID = -2;

//----------------------------------------------------------------------------------------------------------------------

function TCCITTDecoder.FillRun(RunLength: Cardinal): Boolean;

// fills a number of bits with 1s (for black, white only increments pointers),
// returns True if the line has been filled entirely, otherwise False

var
  Run: Cardinal;

begin
  Run := Min(FFreeTargetBits, RunLength);
  // fill remaining bits in the current byte
  if Run in [1..7] then
  begin
    Dec(FFreeTargetBits, Run);
    if not FIsWhite then FTarget^ := FTarget^ or (((1 shl Run) - 1) shl FFreeTargetBits);
    if FFreeTargetBits = 0 then
    begin
      Inc(FTarget);
      FFreeTargetBits := 8;
    end;
    Run := RunLength - Run;
  end
  else Run := RunLength;

  // fill entire bytes whenever possible
  if Run > 0 then
  begin
    if not FIsWhite then FillChar(FTarget^, Run div 8, $FF);
    Inc(FTarget, Run div 8);
    Run := Run mod 8;