bmpfilt.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

                  begin
                    if (x and 1) = 0 then
                      px^ := IOParams.ColorMap^[bits2^ shr 4]
                    else
                    begin
                      px^ := IOParams.ColorMap^[bits2^ and $0F];
                      inc(bits2);
                    end;
                    inc(px);
                  end;
                end;
              end;
              freemem(bits);
            end
            else if xCompression = BI_RLE4 then
            begin
              // RLE4 compression
              getmem(bits, xImageDim);
              fs.Read(bits^, xImageDim);
              if IOParams.IsNativePixelFormat then
              begin
                // native format
                Bitmap.PaletteUsed := 16;
                DecompRLE4_to8(Bitmap, bits, xImageDim, IOParams.ColorMap, Progress, inverter);
              end
              else
                // 4 bit to 24 bit
                DecompRLE4_to24(Bitmap, bits, xImageDim, IOParams.ColorMap, Progress, inverter);
              freemem(bits);
            end;
          end; // endif not preview
        end;
      8:
        begin // 8 bit per pixel
          IOParams.BitsPerSample := 8;
          IOParams.SamplesPerPixel := 1;
          if not Preview then
          begin
            if IOParams.IsNativePixelFormat then
              // set color map
              for y := 0 to IOParams.ColorMapCount - 1 do
                Bitmap.Palette[y] := IOParams.ColorMap[y];
            if xCompression = BI_RLE8 then
            begin
              // RLE8 compression
              getmem(bits, xImageDim);
              fs.Read(bits^, xImageDim);
              if IOParams.IsNativePixelFormat then
              begin
                // native format
                Bitmap.PaletteUsed := 256;
                DecompRLE8_to8(Bitmap, bits, xImageDim, IOParams.ColorMap, Progress, inverter);
              end
              else
                // 8 bit to 24 bit
                DecompRLE8_to24(Bitmap, bits, xImageDim, IOParams.ColorMap, Progress, inverter);
              freemem(bits);
            end
            else if xCompression = BI_RGB then
            begin
              // no compression
              getmem(bits, lw * Bitmap.height);
              fs.Read(bits^, lw * Bitmap.height);
              bitmapheight1 := Bitmap.Height - 1;
              bitmapwidth1 := Bitmap.Width - 1;
              for y := bitmapheight1 downto 0 do
              begin
                // OnProgress
                with Progress do
                  if assigned(fOnProgress) then
                    fOnProgress(Sender, trunc(per1 * (BitmapHeight1 - y)));
                if Progress.Aborting^ then
                  break;
                bits2 := bits;
                inc(bits2, lw * (Bitmapheight1 - y));
                if IOParams.IsNativePixelFormat then
                begin
                  // native format
                  Bitmap.PaletteUsed := 256;
                  copymemory(Bitmap.Scanline[abs(inverter - y)], bits2, bitmap.Width);
                end
                else
                begin
                  // 8 bit to 24 bit
                  px := Bitmap.Scanline[abs(inverter - y)];
                  for x := 0 to bitmapwidth1 do
                  begin
                    px^ := IOParams.ColorMap^[bits2^];
                    inc(bits2);
                    inc(px);
                  end;
                end;
              end;
              freemem(bits);
            end;
          end; // endif not Preview
        end;
      16:
        begin // 16 bit per pixel
          IOParams.BitsPerSample := 5;
          IOParams.SamplesPerPixel := 3;
          if not Preview then
          begin
            getmem(bits, lw); // alloc one row
            if xCompression = BI_RGB then
            begin
              // 5-5-5 pixel format
              BitFields[0] := $7C00;
              BitFields[1] := $03E0;
              BitFields[2] := $001F;
            end; // otherwise it is BI_BITFIELDS , values already loaded in BitFields
            rbitcount := _GetBitCount(BitFields[0]);
            gbitcount := _GetBitCount(BitFields[1]);
            bbitcount := _GetBitCount(BitFields[2]);
            rshift := (gbitCount + bbitCount) - (8 - rbitCount);
            gshift := bbitCount - (8 - gbitCount);
            bshift := 8 - bbitCount;
            bitmapheight1 := Bitmap.Height - 1;
            bitmapwidth1 := Bitmap.Width - 1;
            for y := bitmapheight1 downto 0 do
            begin
              // OnProgress
              with Progress do
                if assigned(fOnProgress) then
                  fOnProgress(Sender, trunc(per1 * (BitmapHeight1 - y)));
              if Progress.Aborting^ then
                break;
              fs.Read(bits^, lw); // load a row
              px := Bitmap.Scanline[abs(inverter - y)];
              wbits := pword(bits);
              for x := 0 to bitmapwidth1 do
              begin
                px^.r := (wbits^ and BitFields[0]) shr rshift;
                px^.g := (wbits^ and BitFields[1]) shr gshift;
                px^.b := (wbits^ and BitFields[2]) shl bshift;
                inc(px);
                inc(wbits);
              end;
            end;
            freemem(bits);
          end; // endif not preview
        end;
      24:
        begin // 24 bit per pixel
          IOParams.BitsPerSample := 8;
          IOParams.SamplesPerPixel := 3;
          if not Preview then
          begin
            bitmapheight1 := Bitmap.Height - 1;
            for y := BitmapHeight1 downto 0 do
            begin
              // OnProgress
              with Progress do
                if assigned(fOnProgress) then
                  fOnProgress(Sender, trunc(per1 * (BitmapHeight1 - y)));
              if Progress.Aborting^ then
                break;
              fs.read(pbyte(Bitmap.Scanline[abs(inverter - y)])^, lw);
            end;
          end; // endif not Preview
        end;
      32:
        begin // 32 bit per pixel
          IOParams.BitsPerSample := 8;
          IOParams.SamplesPerPixel := 4;
          if not Preview then
          begin
            if not IgnoreAlpha then
            begin
              if not assigned(AlphaChannel) then
                AlphaChannel := TIEMask.Create;
              AlphaChannel.AllocateBits(Bitmap.Width, Bitmap.Height, 8);
              AlphaChannel.Fill(255);
            end;
            allzeroalpha:=true;
            getmem(bits, lw);
            bitmapheight1 := Bitmap.Height - 1;
            bitmapwidth1 := Bitmap.Width - 1;
            for y := bitmapheight1 downto 0 do
            begin
              // OnProgress
              with Progress do
                if assigned(fOnProgress) then
                  fOnProgress(Sender, trunc(per1 * (BitmapHeight1 - y)));
              if Progress.Aborting^ then
                break;
              px := Bitmap.Scanline[abs(inverter - y)];
              fs.read(bits^, lw);
              bits2 := bits;
              for x := 0 to bitmapwidth1 do
              begin
                px^.b := bits2^;
                inc(bits2);
                px^.g := bits2^;
                inc(bits2);
                px^.r := bits2^;
                inc(bits2);
                if not IgnoreAlpha then
                begin
                  AlphaChannel.SetPixel(x,y,bits2^);
                  if allzeroalpha then
                    allzeroalpha:= bits2^=0;
                end;
                inc(bits2);
                inc(px);
              end;
            end;
            if not IgnoreAlpha and (AlphaChannel.Full or allzeroalpha) then
              FreeAndNil(AlphaChannel);
            freemem(bits);
          end; // endif not preview
        end;
    end;
  finally
    freemem(ColorMap4);
    freemem(InfoHead);
    freemem(CoreHead);
  end;
{$WARNINGS ON}
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

// compress a row to RLE4
// px: uncompressed buffer
// Width: number of bytes of px
// rowbuf: compressed bufer (output)
// rest. size of compressed buffer
// note: each byte of px contains a pixel (nibble)

function CompressRLE4row(px: pbytearray; Width: integer; rowbuf: pbyte): integer;
var
  p1, p2: integer;
  pb: integer;
  q: integer;
  basbuf: pbyte;
  procedure WAbs;
  var
    q, w: integer;
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('CompressRLE4row.WAbs'); {$endif}
    while p1 - pb > 0 do
    begin
      q := imin(p1 - pb, 255); // byte count (p1 not included)
      if q = 1 then
      begin
        // only one, code as runlength
        rowbuf^ := 1;
        inc(rowbuf);
        rowbuf^ := px^[pb] shl 4;
        inc(rowbuf);
      end
      else if q = 2 then
      begin
        // two, again runlength
        rowbuf^ := 2;
        inc(rowbuf);
        rowbuf^ := (px^[pb] shl 4) or px^[pb + 1];
        inc(rowbuf);
      end
      else
      begin
        // they are 3 o more, code as absolute
        rowbuf^ := 0;
        inc(rowbuf); // ESC
        rowbuf^ := q;
        inc(rowbuf);
        for w := 0 to (q shr 1) - 1 do
        begin
          rowbuf^ := (px^[pb + w * 2] shl 4) or px^[pb + w * 2 + 1];
          inc(rowbuf);
        end;
        if q and 1 <> 0 then
        begin
          rowbuf^ := px^[pb] shl 4;
          inc(rowbuf);
        end;
        w := (q shr 1) + (q and 1);
        if w and 1 <> 0 then
          inc(rowbuf);
      end;
      inc(pb, q);
    end;
    {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
  end;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('CompressRLE4row'); {$endif}
  basbuf := rowbuf;
  p1 := 0;
  pb := 0;
  while p1 < Width do
  begin
    if p1 - pb > 255 then
    begin
      WAbs;
      //pb:=0;
    end;
    if px^[p1] = px^[p1 + 1] then
    begin
      // * found at least 2 equals
        // write previsous bytes as absolute (from pb)
      if pb < p1 then
        WAbs;
      // look for other equal bytes
      p2 := p1 + 2;
      while (p2 < Width) and (px^[p1] = px^[p2]) and (p2 - p1 < 255) do
        inc(p2);
      // write p2-p1 (p2 not included) times same byte
      q := p2 - p1;
      rowbuf^ := q;
      inc(rowbuf);
      rowbuf^ := (px^[p1] shl 4) or px^[p1];
      inc(rowbuf);
      pb := p2;
      p1 := pb;
    end
    else
      inc(p1);
  end;
  if pb < p1 then
    WAbs;
  rowbuf^ := 0;
  inc(rowbuf); // ESC
  rowbuf^ := 0; // EOL
  result := integer(rowbuf) - integer(basbuf) + 1;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

// returns size of compressed buffer
// px: uncompressed buffer
// Width: number of bytes of px
// rowbuf: compressed bufer (output)
// compress a row to RLE4

function CompressRLE8row(px: pbytearray; Width: integer; rowbuf: pbyte): integer;
var
  p1, p2: integer;
  pb: integer;
  q: integer;
  basbuf: pbyte;
  procedure WAbs;
  var
    q, w: integer;
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('CompressRLE8row.WAbs'); {$endif}
    while p1 - pb > 0 do
    begin
      q := imin(p1 - pb, 255); // numero byte (p1 non compreso)
      if q = 1 then
      begin
        // uno solo, codifica come run length
        rowbuf^ := 1;
        inc(rowbuf);
        rowbuf^ := px^[pb];
        inc(rowbuf);
      end
      else if q = 2 then
      begin
        // due, ancora run length
        rowbuf^ := 1;
        inc(rowbuf);
        rowbuf^ := px^[pb];
        inc(rowbuf);
        rowbuf^ := 1;
        inc(rowbuf);
        rowbuf^ := px^[pb + 1];
        inc(rowbuf);
      end
      else
      begin
        // sono 3 o pi