dib.pas

传奇源代码的delphi版本

  end else
  begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
    if FCompressed then
    begin
      FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
      GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
      Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
    end else
    begin
      Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
    end;
  end;
end;

procedure TDIBSharedImage.Compress(Source: TDIBSharedImage);

  procedure EncodeRLE4;
  var
    Size: Integer;

    function AllocByte: PByte;
    begin
      if Size mod 4096 = 0 then
        ReAllocMem(FPBits, Size + 4095);
      Result := Pointer(Integer(FPBits) + Size);
      Inc(Size);
    end;

  var
    B1, B2, C: Byte;
    PB1, PB2: Integer;
    Src: PByte;
    X, Y: Integer;

    function GetPixel(x: Integer): Integer;
    begin
      if X and 1 = 0 then
        Result := PArrayByte(Src)[X shr 1] shr 4
      else
        Result := PArrayByte(Src)[X shr 1] and $0F;
    end;

  begin
    Size := 0;

    for y := 0 to Source.FHeight - 1 do
    begin
      x := 0;
      Src := Pointer(Integer(Source.FPBits) + y * FWidthBytes);
      while x < Source.FWidth do
      begin
        if (Source.FWidth - x > 3) and (GetPixel(x) = GetPixel(x + 2)) then
        begin
          {  Encoding mode  }
          B1 := 2;
          B2 := (GetPixel(x) shl 4) or GetPixel(x + 1);

          Inc(x, 2);

          C := B2;

          while (x < Source.FWidth) and (C and $F = GetPixel(x)) and (B1 < 255) do
          begin
            Inc(B1);
            Inc(x);
            C := (C shr 4) or (C shl 4);
          end;

          AllocByte^ := B1;
          AllocByte^ := B2;
        end else
          if (Source.FWidth - x > 5) and ((GetPixel(x) <> GetPixel(x + 2)) or (GetPixel(x + 1) <> GetPixel(x + 3))) and
            ((GetPixel(x + 2) = GetPixel(x + 4)) and (GetPixel(x + 3) = GetPixel(x + 5))) then
          begin
          {  Encoding mode }
            AllocByte^ := 2;
            AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
            Inc(x, 2);
          end else
          begin
            if (Source.FWidth - x < 4) then
            begin
            {  Encoding mode }
              while Source.FWidth - x >= 2 do
              begin
                AllocByte^ := 2;
                AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
                Inc(x, 2);
              end;

              if Source.FWidth - x = 1 then
              begin
                AllocByte^ := 1;
                AllocByte^ := GetPixel(x) shl 4;
                Inc(x);
              end;
            end else
            begin
            {  Absolute mode  }
              PB1 := Size; AllocByte;
              PB2 := Size; AllocByte;

              B1 := 0;
              B2 := 4;

              AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
              AllocByte^ := (GetPixel(x + 2) shl 4) or GetPixel(x + 3);

              Inc(x, 4);

              while (x + 1 < Source.FWidth) and (B2 < 254) do
              begin
                if (Source.FWidth - x > 3) and (GetPixel(x) = GetPixel(x + 2)) and (GetPixel(x + 1) = GetPixel(x + 3)) then
                  Break;

                AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
                Inc(B2, 2);
                Inc(x, 2);
              end;

              PByte(Integer(FPBits) + PB1)^ := B1;
              PByte(Integer(FPBits) + PB2)^ := B2;
            end;
          end;

        if Size and 1 = 1 then AllocByte;
      end;

      {  End of line  }
      AllocByte^ := 0;
      AllocByte^ := 0;
    end;

    {  End of bitmap  }
    AllocByte^ := 0;
    AllocByte^ := 1;

    FBitmapInfo.bmiHeader.biSizeImage := Size;
    FSize := Size;
  end;

  procedure EncodeRLE8;
  var
    Size: Integer;

    function AllocByte: PByte;
    begin
      if Size mod 4096 = 0 then
        ReAllocMem(FPBits, Size + 4095);
      Result := Pointer(Integer(FPBits) + Size);
      Inc(Size);
    end;

  var
    B1, B2: Byte;
    PB1, PB2: Integer;
    Src: PByte;
    X, Y: Integer;
  begin
    Size := 0;

    for y := 0 to Source.FHeight - 1 do
    begin
      x := 0;
      Src := Pointer(Integer(Source.FPBits) + y * FWidthBytes);
      while x < Source.FWidth do
      begin
        if (Source.FWidth - x > 2) and (Src^ = PByte(Integer(Src) + 1)^) then
        begin
          {  Encoding mode  }
          B1 := 2;
          B2 := Src^;

          Inc(x, 2);
          Inc(Src, 2);

          while (x < Source.FWidth) and (Src^ = B2) and (B1 < 255) do
          begin
            Inc(B1);
            Inc(x);
            Inc(Src);
          end;

          AllocByte^ := B1;
          AllocByte^ := B2;
        end else
          if (Source.FWidth - x > 2) and (Src^ <> PByte(Integer(Src) + 1)^) and (PByte(Integer(Src) + 1)^ = PByte(Integer(Src) + 2)^) then
          begin
          {  Encoding mode }
            AllocByte^ := 1;
            AllocByte^ := Src^; Inc(Src);
            Inc(x);
          end else
          begin
            if (Source.FWidth - x < 4) then
            begin
            {  Encoding mode }
              if Source.FWidth - x = 2 then
              begin
                AllocByte^ := 1;
                AllocByte^ := Src^; Inc(Src);

                AllocByte^ := 1;
                AllocByte^ := Src^; Inc(Src);
                Inc(x, 2);
              end else
              begin
                AllocByte^ := 1;
                AllocByte^ := Src^; Inc(Src);
                Inc(x);
              end;
            end else
            begin
            {  Absolute mode  }
              PB1 := Size; AllocByte;
              PB2 := Size; AllocByte;

              B1 := 0;
              B2 := 3;

              Inc(x, 3);

              AllocByte^ := Src^; Inc(Src);
              AllocByte^ := Src^; Inc(Src);
              AllocByte^ := Src^; Inc(Src);

              while (x < Source.FWidth) and (B2 < 255) do
              begin
                if (Source.FWidth - x > 3) and (Src^ = PByte(Integer(Src) + 1)^) and (Src^ = PByte(Integer(Src) + 2)^) and (Src^ = PByte(Integer(Src) + 3)^) then
                  Break;

                AllocByte^ := Src^; Inc(Src);
                Inc(B2);
                Inc(x);
              end;

              PByte(Integer(FPBits) + PB1)^ := B1;
              PByte(Integer(FPBits) + PB2)^ := B2;
            end;
          end;

        if Size and 1 = 1 then AllocByte;
      end;

      {  End of line  }
      AllocByte^ := 0;
      AllocByte^ := 0;
    end;

    {  End of bitmap  }
    AllocByte^ := 0;
    AllocByte^ := 1;

    FBitmapInfo.bmiHeader.biSizeImage := Size;
    FSize := Size;
  end;

begin
  if Source.FCompressed then
    Duplicate(Source, Source.FMemoryImage)
  else begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, True, True);
    case FBitmapInfo.bmiHeader.biCompression of
      BI_RLE4: EncodeRLE4;
      BI_RLE8: EncodeRLE8;
    else
      Duplicate(Source, Source.FMemoryImage);
    end;
  end;
end;

procedure TDIBSharedImage.Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);

  procedure DecodeRLE4;
  var
    B1, B2, C: Byte;
    Dest, Src, P: PByte;
    X, Y, i: Integer;
  begin
    Src := Source.FPBits;
    X := 0;
    Y := 0;

    while True do
    begin
      B1 := Src^; Inc(Src);
      B2 := Src^; Inc(Src);

      if B1 = 0 then
      begin
        case B2 of
          0: begin {  End of line  }
              X := 0;
              Inc(Y);
            end;
          1: Break; {  End of bitmap  }
          2: begin {  Difference of coordinates  }
              Inc(X, B1);
              Inc(Y, B2); Inc(Src, 2);
            end;
        else
          {  Absolute mode  }
          Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);

          C := 0;
          for i := 0 to B2 - 1 do
          begin
            if i and 1 = 0 then
            begin
              C := Src^; Inc(Src);
            end else
            begin
              C := C shl 4;
            end;

            P := Pointer(Integer(Dest) + X shr 1);
            if X and 1 = 0 then
              P^ := (P^ and $0F) or (C and $F0)
            else
              P^ := (P^ and $F0) or ((C and $F0) shr 4);

            Inc(X);
          end;
        end;
      end else
      begin
        {  Encoding mode  }
        Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);

        for i := 0 to B1 - 1 do
        begin
          P := Pointer(Integer(Dest) + X shr 1);
          if X and 1 = 0 then
            P^ := (P^ and $0F) or (B2 and $F0)
          else
            P^ := (P^ and $F0) or ((B2 and $F0) shr 4);

          Inc(X);

          // Swap nibble
          B2 := (B2 shr 4) or (B2 shl 4);
        end;
      end;

      {  Word arrangement  }
      Inc(Src, Longint(Src) and 1);
    end;
  end;

  procedure DecodeRLE8;
  var
    B1, B2: Byte;
    Dest, Src: PByte;
    X, Y: Integer;
  begin
    Dest := FPBits;
    Src := Source.FPBits;
    X := 0;
    Y := 0;

    while True do
    begin
      B1 := Src^; Inc(Src);
      B2 := Src^; Inc(Src);

      if B1 = 0 then
      begin
        case B2 of
          0: begin {  End of line  }
              X := 0; Inc(Y);
              Dest := Pointer(Longint(FPBits) + Y * FWidthBytes + X);
            end;
          1: Break; {  End of bitmap  }
          2: begin {  Difference of coordinates  }
              Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
              Dest := Pointer(Longint(FPBits) + Y * FWidthBytes + X);
            end;
        else
          {  Absolute mode  }
          Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
        end;
      end else
      begin
        {  Encoding mode  }
        FillChar(Dest^, B1, B2); Inc(Dest, B1);
      end;

      {  Word arrangement  }
      Inc(Src, Longint(Src) and 1);
    end;
  end;

begin
  if not Source.FCompressed then
    Duplicate(Source, MemoryImage)
  else begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
    case Source.FBitmapInfo.bmiHeader.biCompression of
      BI_RLE4: DecodeRLE4;
      BI_RLE8: DecodeRLE8;
    else
      Duplicate(Source, MemoryImage);
    end;
  end;
end;

procedure TDIBSharedImage.ReadData(Stream: TStream; MemoryImage: Boolean);
var
  BI: TBitmapInfoHeader;
  BC: TBitmapCoreHeader;
  BCRGB: array[0..255] of TRGBTriple;

  procedure LoadRLE4;
  begin
    FSize := BI.biSizeImage;
    //GetMem(FPBits, FSize);
    FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
    FBitmapInfo.bmiHeader.biSizeImage := FSize;
    Stream.ReadBuffer(FPBits^, FSize);
  end;

  procedure LoadRLE8;
  begin
    FSize := BI.biSizeImage;
    //GetMem(FPBits, FSize);
    FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
    FBitmapInfo.bmiHeader.biSizeImage := FSize;
    Stream.ReadBuffer(FPBits^, FSize);
  end;

  procedure LoadRGB;
  var
    y: Integer;
  begin
    if BI.biHeight < 0 then
    begin
      for y := 0 to Abs(BI.biHeight) - 1 do
        Stream.ReadBuffer(Pointer(Integer(FTopPBits) + y * FNextLine)^, FWidthBytes);
    end else
    begin
      Stream.ReadBuffer(FPBits^, FSize);
    end;
  end;

var
  i, PalCount: Integer;
  OS2: Boolean;
  Localpf: TLocalDIBPixelFormat;
  AColorTable: TRGBQuads;
  APixelFormat: TDIBPixelFormat;
begin
  {  Header size reading  }
  i := Stream.Read(BI.biSize, 4);

  if i = 0 then
  begin
    Create;
    Exit;
  end;
  if i <> 4 then
    raise EInvalidGraphic.Create(SInvalidDIB);

  {  Kind check of DIB  }
  OS2 := False;

  case BI.biSize of
    SizeOf(TBitmapCoreHeader):