dib.pas.svn-base

Asphyre的传奇WIL,可以用Asphyre来写传奇了

  FillChar(FBitmapInfo^, FBitmapInfoSize, 0);

  {  BitmapInfo setting.  }
  with FBitmapInfo^.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := FWidth;
    biHeight := FHeight;
    biPlanes := 1;
    biBitCount := FBitCount;
    if UsePixelFormat then
      biCompression := BI_BITFIELDS
    else
    begin
      if (FBitCount = 4) and (Compressed) then
        biCompression := BI_RLE4
      else if (FBitCount = 8) and (Compressed) then
        biCompression := BI_RLE8
      else
        biCompression := BI_RGB;
    end;
    biSizeImage := FSize;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed := 0;
    biClrImportant := 0;
  end;
  InfoOfs := SizeOf(TBitmapInfoHeader);

  if UsePixelFormat then
  begin
    with PLocalDIBPixelFormat(Integer(FBitmapInfo) + InfoOfs)^ do
    begin
      RBitMask := PixelFormat.RBitMask;
      GBitMask := PixelFormat.GBitMask;
      BBitMask := PixelFormat.BBitMask;
    end;

    Inc(InfoOfs, SizeOf(TLocalDIBPixelFormat));
  end;

  FColorTablePos := InfoOfs;

  FColorTable := ColorTable;
  Move(FColorTable, Pointer(Integer(FBitmapInfo) + FColorTablePos)^, SizeOf(TRGBQuad) * FPaletteCount);

  FCompressed := FBitmapInfo^.bmiHeader.biCompression in [BI_RLE4, BI_RLE8];
  FMemoryImage := MemoryImage or FCompressed;

  {  DIB making.  }
  if not Compressed then
  begin
    if MemoryImage then
    begin
      FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
      if FPBits = nil then
        OutOfMemoryError;
    end else
    begin
      FDC := CreateCompatibleDC(0);

      FHandle := CreateDIBSection(FDC, FBitmapInfo^, DIB_RGB_COLORS, FPBits, 0, 0);
      if FHandle = 0 then
        raise EOutOfResources.CreateFmt(SCannotMade, ['DIB']);

      FOldHandle := SelectObject(FDC, FHandle);
    end;
  end;

  FTopPBits := Pointer(Integer(FPBits) + (FHeight - 1) * FWidthBytes);
end;

procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
begin
  if Source.FSize = 0 then
  begin
    Create;
    FMemoryImage := MemoryImage;
  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  }