ietgafil.pas

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

(*
Copyright (c) 1998-2007 by HiComponents. All rights reserved.

This software comes without express or implied warranty.
In no case shall the author be liable for any damage or unwanted behavior of any
computer hardware and/or software.

HiComponents grants you the right to include the compiled component
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE,
BUT YOU MAY NOT DISTRIBUTE THIS SOURCE CODE OR ITS COMPILED .DCU IN ANY FORM.

ImageEn, IEvolution and ImageEn ActiveX may not be included in any commercial,
shareware or freeware libraries or components.

email: [e-mail]

http://www.hicomponents.com
*)

unit ietgafil;

{$R-}
{$Q-}

{$I ie.inc}

interface

uses Windows, Classes, Graphics, SysUtils, ImageEnIO, hyiedefs, hyieutils;

procedure ReadTGAStream(Stream: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec; Preview: boolean; var AlphaChannel: TIEMask; IgnoreAlpha: boolean);
procedure WriteTGAStream(Stream: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec; AlphaChannel: TIEMask);
function TryTGA(Stream: TStream): boolean;

implementation

uses ImageEnProc, neurquant, ImageEnView, ieview;

{$R-}

type
  TGAHeader = packed record
    IdentSize: Byte; // length of Identifier String
    ColorMaptype: Byte; // 0 = no map
    Imagetype: Byte; // image type
    ColorMapStart: Word; // index of first color map entry
    ColorMapLength: Word; // number of entries in color map
    ColorMapBits: Byte; // size of color map entry (15,16,24,32)
    XStart: Word; // x origin of image
    YStart: Word; // y origin of image
    Width: Word; // width of image
    Height: Word; // height of image
    Bits: Byte; // pixel size (8,16,24,32)
    Descriptor: Byte; // image descriptor
  end;

  TGAFooter = packed record
    ExtensionArea: dword;
    DeveloperDir: dword;
    Signature: array[0..17] of char; // must be 'TRUEVISION-XFILE.\0'
  end;

  TGAExtension = packed record
    ExtSize: word;
    AuthorName: array[0..40] of char;
    AuthorComments: array[0..323] of char;
    DateTime: array[0..5] of word;
    JobName: array[0..40] of char;
    JobTime: array[0..2] of word;
    SoftwareID: array[0..40] of char;
    SoftwareVer: array[0..2] of byte;
    KeyColor: array[0..3] of byte;
    AspectRatio: array[0..1] of word;
    Gamma: array[0..1] of word;
    ColorCorrection: dword;
    PostageStamp: dword;
    ScanLine: dword;
    AttributesType: byte;
  end;

  TRC = record
    IndexData: array[0..8192 - 1] of Byte;
    Palette256: array[0..255] of TRGB;
    alpha256: array [0..255] of byte;
    hasalpha256: boolean;
    TempArrayD: PBYTEROW;
    //TempArrayD2: PBYTEROW;
    TempArrayDBIg: PBYTEROW;
    TempArrayAlpha: PBYTEROW;
    CompRow: PBYTEROW;
    Index1: Word;
    Index2: Word;
    Newtype: boolean;
    Footer: TGAFooter;
    Extension: TGAExtension;
    sbase: integer;
    RemSize,RemCode:integer;
  end;
  PRC = ^TRC;

  //////////////////////////////////////////////////////////////////////////////////////////

function TryTGA(Stream: TStream): boolean;
var
  TGAHead: TGAHeader;
  c: Char;
  B: Byte;
  sp: int64;
begin
  sp := Stream.Position;
  // Read Targa Header
  Stream.Read(TGAHead, Sizeof(TGAHeader));
  if (TGAHead.Imagetype in [1, 2, 3, 9, 10, 11]) and (TGAHead.Bits in [1, 4, 8, 16, 24, 32]) and
    (TGAHead.ColorMaptype < 2) and (TGAHead.Width>0) and (TGAHead.Height>0) then
  begin
    result := true;
    Stream.Position := sp;
    Stream.Read(c, 1);
    if c = 'P' then
    begin
      Stream.Read(b, 1);
      if (b - 48 > 01) and (b - 48 < 7) then
      begin
        Stream.Read(c, 1);
        if (c <> ' ') and (c <> '#') and (c <> #$0A) then
          result := false;
      end;
    end;
  end
  else
    result := false;
  Stream.Position := sp;
end;

procedure SetUpMaskGrayPalette(var rc: TRC);
var
  J: integer;
begin
  for J := 0 to 255 do
    with rc.Palette256[J] do
    begin
      r := J;
      g := J;
      b := J;
    end;
end;

procedure MakeGenPalette(var rc: TRC);
var
  X: integer;
  R, G, B: Word;
begin
  with rc do
  begin
    X := 0;
    for R := 0 to 7 do
      for G := 0 to 7 do
        for B := 0 to 3 do
        begin
          Palette256[X].r := ((R + 1) * 8 - 1) * 4;
          Palette256[X].g := ((G + 1) * 8 - 1) * 4;
          Palette256[X].b := ((B + 1) * 16 - 1) * 4;
          Inc(X);
        end;
  end;
end;

///////////////////////////////////////////////////////////////////////////////////

procedure ReadTGAStream(Stream: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec; Preview: boolean; var AlphaChannel: TIEMask; IgnoreAlpha: boolean);
var
  rc: PRC;
  Width: Word;
  Height: Word;
  BitsPerPixel: SmallInt;
  Compressed: Boolean;
  TGAHead: TGAHeader;
  FileOk: Boolean;
  //
  procedure FileGetMore;
  var
    NumRead: integer;
  begin
    with rc^ do
    begin
      NumRead := Stream.Size - Stream.Position;
      //FillChar(IndexData,8192,0);
      if NumRead < 8192 then
      begin
        Stream.Read(IndexData, NumRead);
        Index1 := NumRead;
      end
      else
      begin
        Stream.Read(IndexData, 8192);
        Index1 := 8192;
      end;
      Index2 := 0;
    end;
  end;
  //
  procedure FastGetBytes(var Ptr1; NumBytes: Word);
  var
    X: Integer;
  begin
    with rc^ do
    begin
      // if we have enough the block it! Otherwise do one at a time!
      if Index1 < NumBytes then
      begin
        if Index1 = 0 then
          FileGetMore;
        for X := 0 to NumBytes - 1 do
        begin
          TBYTEROW(Ptr1)[X] := IndexData[Index2];
          Inc(Index2);
          Dec(Index1);
          if Index1 = 0 then
            FileGetMore;
        end;
      end
      else
      begin
        // Block it fast!
        Move(IndexData[Index2], TBYTEROW(Ptr1)[0], NumBytes);
        Index2 := Index2 + Numbytes;
        Index1 := Index1 - NumBytes;
      end;
    end;
  end;
  //
  function FastGetByte: Byte;
  begin
    with rc^ do
    begin
      if Index1 = 0 then
        FileGetMore;
      FastGetByte := IndexData[Index2];
      Inc(Index2);
      Dec(Index1);
    end;
  end;
  //
  function FastGetWord: Word;
  begin
    FastGetWord := Word(FastGetByte) + Word(FastGetByte) * 256;
  end;
  //
  procedure ReadTGAFileHeader(var FileOk: Boolean;
    var Width: Word; var Height: Word; var BitsPerPixel: SmallInt;
    var Compressed: Boolean);
  var
    W1: Word;
    I: integer;
    ss: string;
  begin
    with rc^ do
    begin
      // Read Targa footer (if exists)
      Stream.Seek(-sizeof(TGAFooter), soFromEnd);
      Stream.Read(Footer, sizeof(TGAFooter));
      NewType := Footer.Signature = 'TRUEVISION-XFILE.';
      // default values
      IOParams.TGA_Author := '';
      IOParams.TGA_Date := date;
      IOParams.TGA_ImageName := '';
      IOParams.TGA_Background := CreateRGB(0, 0, 0);
      IOParams.TGA_AspectRatio := 1;
      IOParams.TGA_Gamma := 2.2;
      if NewType then
        with Extension do
        begin
          Stream.Position := sbase + integer(Footer.ExtensionArea);
          Stream.Read(Extension, sizeof(TGAExtension));
          IOParams.TGA_Author := AuthorName;
          try
            if (DateTime[0] <> 0) and (DateTime[1] <> 0) and (DateTime[2] <> 0) and
              (DateTime[2] > 0) and (DateTime[2] < 2500) and
              (DateTime[0] > 0) and (DateTime[0] < 13) and
              (DateTime[1] > 0) and (DateTime[1] < 32) and
              (DateTime[3] < 24) and
              (DateTime[4] < 60) and
              (DateTime[5] < 60) then
              IOParams.TGA_Date := EncodeDate(DateTime[2], DateTime[0], DateTime[1]) +
                EncodeTime(DateTime[3], DateTime[4], DateTime[5], 0);
          except
          end;
          IOParams.TGA_ImageName := JobName;
          IOParams.TGA_Background := CreateRGB(KeyColor[1], KeyColor[2], KeyColor[3]);
          if (AspectRatio[0] <> 0) and (AspectRatio[1] <> 0) then
            IOParams.TGA_AspectRatio := AspectRatio[0] / AspectRatio[1];
          if (Gamma[0] <> 0) and (Gamma[1] <> 0) then
            IOParams.TGA_Gamma := Gamma[0] / Gamma[1];
        end;
      Stream.Position := sbase;
      // Read Targa Header
      FastGetBytes(TGAHead, Sizeof(TGAHeader));
      IOParams.TGA_XPos := TGAHead.XStart;
      IOParams.TGA_YPos := TGAHead.YStart;
      FileOk := (TGAHead.Imagetype in [1, 2, 3, 9, 10, 11]) and (TGAHead.Bits in [1, 4, 8, 16, 24, 32]);
      if FileOk then
      begin
        Width := TGAHead.Width;
        Height := TGAHead.Height;
        BitsPerPixel := TGAHead.Bits;
        SetLength(ss, TGAHead.IdentSize);
        FastGetBytes(ss[1], TGAHead.IdentSize);
        IOParams.TGA_Descriptor := ss;
        // Read in colormap
        MakeGenPalette(rc^);
        if TGAHead.ColorMaptype = 1 then
        begin
          case TGAHead.ColorMapBits of
            15, 16:
              for I := TGAHead.ColorMapStart to TGAHead.ColorMapStart + TGAHead.ColorMapLength - 1 do
              begin
                W1 := FastGetWord;
                Palette256[I].r := (((W1 shr 10) and $1F) shl 1) * 4;
                Palette256[I].g := (((W1 shr 5) and $1F) shl 1) * 4;
                Palette256[I].b := (((W1 shr 0) and $1F) shl 1) * 4;
              end;
            24:
              for I := TGAHead.ColorMapStart to TGAHead.ColorMapStart + TGAHead.ColorMapLength - 1 do
              begin
                Palette256[I].b := FastGetByte;
                Palette256[I].g := FastGetByte;
                Palette256[I].r := FastGetByte;
              end;
            32:
              begin
                hasalpha256:=true;
                for I := TGAHead.ColorMapStart to TGAHead.ColorMapStart + TGAHead.ColorMapLength - 1 do
                begin
                  Palette256[I].b := FastGetByte;
                  Palette256[I].g := FastGetByte;
                  Palette256[I].r := FastGetByte;
                  alpha256[I]:=FastGetByte;
                end;
              end;
          end;
          if IOParams.ColorMap <> nil then
          begin
            freemem(IOParams.ColorMap);
            IOParams.fColorMap := nil;
            IOParams.fColorMapCount := 0;
          end;
          IOParams.fColorMapCount := TGAHead.ColorMapLength;
          IOParams.fColorMap := allocmem(TGAHead.ColorMapLength * sizeof(TRGB));
          move(Palette256[0], IOParams.fcolorMap^[0], TGAHead.ColorMapLength * sizeof(TRGB));
          IOParams.TGA_GrayLevel := false;
        end
        else if BitsPerPixel = 8 then
        begin
          // gray level image (8bpp but without colormap)
          SetUpMaskGrayPalette(rc^);
          IOParams.TGA_GrayLevel := true;
        end
        else if BitsPerPixel = 1 then
        begin
          // bilevel image
          Palette256[0] := CreateRGB(0, 0, 0);
          Palette256[1] := CreateRGB(255, 255, 255);
        end;
        Compressed := TGAHead.Imagetype in [9, 10, 11];
        IOParams.TGA_Compressed := Compressed;
      end;
    end;
  end;
  //
const
  MaskTable: array[0..7] of Byte = (128, 64, 32, 16, 8, 4, 2, 1);
var
  II: Word;
  LineBytes: Word;
  StartLine, IncLine, I: SmallInt;
  Ptr1: Pointer;
  //
  procedure PixelSwapArray(var TempArrayD; Wide: Word);
  var
    W, X, Y, Z: integer;
    Byte1, Byte2, Byte3: Byte;
  begin
    // Should I do 1 byte pixel or 3 byte pixels
    case BitsPerPixel of
      8:
        begin
          Y := Wide shr 1;
          Z := Wide - 1;
          for X := 0 to Y - 1 do
          begin
            Byte1 := TBYTEROW(TempArrayD)[X];
            TBYTEROW(TempArrayD)[X] := TBYTEROW(TempArrayD)[Z];
            TBYTEROW(TempArrayD)[Z] := Byte1;
            Dec(Z);
          end;
        end;
      24:
        begin
          Y := (Wide div 3) div 2;
          Z := Wide - 3;
          W := 0;
          for X := 0 to Y - 1 do
          begin
            Byte1 := TBYTEROW(TempArrayD)[W + 0];
            Byte2 := TBYTEROW(TempArrayD)[W + 1];
            Byte3 := TBYTEROW(TempArrayD)[W + 2];
            TBYTEROW(TempArrayD)[W + 0] := TBYTEROW(TempArrayD)[Z + 0];
            TBYTEROW(TempArrayD)[W + 1] := TBYTEROW(TempArrayD)[Z + 1];