unit TIFformat;

interface

uses IOGraphics;

const  Null: Cardinal = $00000000;
       TIFFHeader         : Array[0..1] of Cardinal = ($002a4949,$00000008);
       TIFFCountPar       : Word = 12;
       TIFFWidth          : Array[0..2] of Cardinal = ($00040100,$00000001,$00000000);
       TIFFHeight         : Array[0..2] of Cardinal = ($00040101,$00000001,$00000000);
       TIFFBits           : Array[0..2] of Cardinal = ($00030102,$00000001,$00000000);
       TIFFCompress       : Array[0..2] of Cardinal = ($00030103,$00000001,$00000001);
       TIFFTypeImage      : Array[0..2] of Cardinal = ($00030106,$00000001,$00000000);
       TIFFLinesInBand    : Array[0..2] of Cardinal = ($00040116,$00000001,$00000000);
       TIFFNumbersInPixel : Array[0..2] of Cardinal = ($00030115,$00000001,$00000000);
       TIFFLengthBands    : Array[0..2] of Cardinal = ($00040117,$00000001,$00000000);
       TIFFPixelsX        : Array[0..2] of Cardinal = ($0005011a,$00000001,$00000000);
       TIFFPixelsY        : Array[0..2] of Cardinal = ($0005011b,$00000001,$00000000);
       TIFFPlanar         : Array[0..2] of Cardinal = ($0003011c,$00000001,$00000001);
       TIFFUnitLength     : Array[0..2] of Cardinal = ($00030128,$00000001,$00000001); (* jednotka neni stanovena *)
       TIFFDataPoint      : Array[0..2] of Cardinal = ($00040111,$00000001,$00000000);

type THeaderTIFF = Array[0..3] of AnsiChar;
     TDirTIFF = record
                  Kategory: Word;
                  TypeDate: Word;
                  Count: Cardinal;
                  Value: Cardinal;
                end{record};
      TTIFFinfo = Array[1..255] of
                record
                  Width          : TDirTIFF; // sirka v pixelech
                  Height         : TDirTIFF; // vyska v pixelech
                  Bits           : TDirTIFF; // pocet bitu na pixel resp. slozku pixelu u RGB
                  Compress       : TDirTIFF; // 1 ... bez komprese
                  TypeImg        : TDirTIFF; // 2...RGB, 3 ... palette color, 0 ... negativ BW, 1 ... BW
                  LinesInBand    : TDirTIFF;
                  NumbersInPixel : TDirTIFF; // Channels (pouze u barevneho obrazu, u BW to neni definovane)
                  LengthBands    : TDirTIFF;
                  PixelsX        : TDirTIFF;
                  PixelsY        : TDirTIFF;
                  Planar         : TDirTIFF;
                  UnitLength     : TDirTIFF;
                  DataPoint      : TDirTIFF;
                  Palette        : TDirTIFF;
                end;

const  PC_HeaderTIFF  : THeaderTIFF = ('I','I',#$2A,#0);
       MAC_HeaderTIFF : THeaderTIFF = ('M','M',#0,#$2A);

procedure GetTiffInfo(FileName : string; var Info: TImgRec; DisplayWarnings : boolean);
procedure ImageToTIFF16(P: Pointer; IW,IH: Integer; Gray: Boolean; SaveFile: String);
procedure ImageToTIFF8(P: Pointer; IW,IH: Integer; Gray: Boolean; SaveFile: String);
procedure ImageToTIFF8ROI(P: Pointer; IW,IH, RoiL,RoiT,RoiW,RoiH : integer; Gray: Boolean; SaveFile: String);

implementation

uses  SysUtils, Dialogs;

procedure Swap4(var C: Cardinal);
type TPole  = array[0..3] of byte;
     PPole  = ^TPole;
var  Pole  : PPole;
     B     : byte;
begin
  Pole:=@C;
  B:=Pole[0];
  Pole[0]:=Pole[3];
  Pole[3]:=B;
  B:=Pole[1];
  Pole[1]:=Pole[2];
  Pole[2]:=B;
 // C:=swap(C);


end;
                                                                          
procedure Swap2(var C: Cardinal);
type TPole  = array[0..3] of byte;
     PPole  = ^TPole;
var Pole : PPole;
    B    : Byte;
    w    : word;
begin
 // Swap4(C);
  Pole:=@C;
  w:=Pole[0]*256 + Pole[1];
  c:=w;
end;

procedure GetTiffInfo(FileName : string; var Info: TImgRec; DisplayWarnings : boolean);
var RGBbits : array[0..2] of word;
    ImgOffset : cardinal;
    n : integer;
    f : file;
    Count: Word;
    PointDir: Cardinal;
    i: Word;
    DirTIFF: TDirTIFF;
    HeaderTIFF: THeaderTIFF;
    TIFFinfo: TTIFFinfo;
    TIFFCount: Byte;
begin
  if not FileExists(FileName) then
    begin
      Info.OK:=False;
      Info.Error:='File: '+ExtractFileName(FileName)+'  not found.';
      Exit;
    end;
  System.Assign(f,FileName);
  System.Reset(f,1);
  {test hlavicky a SwapBytes}
  System.BlockRead(f,HeaderTIFF,4);
  if (HeaderTIFF=PC_HeaderTIFF)  then Info.SwapBytes:=false else
  if (HeaderTIFF=Mac_HeaderTIFF) then Info.SwapBytes:=true else
    begin
      if DisplayWarnings then ShowMessage(FileName+ ' is not correct TIFF file.');
      System.Close(f);
      Exit;
    end;
  System.BlockRead(f,PointDir,4);
  if Info.SwapBytes then Swap4(PointDir);
  TIFFCount:=0;
  while PointDir<>0 do
    begin
      Inc(TIFFCount);
      System.Seek(f,PointDir);
      BlockRead(f,Count,2);
      if Info.SwapBytes then Count:=swap(Count);
      DirTIFF.Kategory :=0;
      DirTIFF.TypeDate :=0;
      DirTIFF.Count    :=0;
      DirTIFF.Value    :=0;
      TIFFinfo[TIFFCount].Width          := DirTIFF;
      TIFFinfo[TIFFCount].Height         := DirTIFF;
      TIFFinfo[TIFFCount].Bits           := DirTIFF;
      TIFFinfo[TIFFCount].Compress       := DirTIFF;
      TIFFinfo[TIFFCount].TypeImg        := DirTIFF;
      TIFFinfo[TIFFCount].LinesInBand    := DirTIFF;
      TIFFinfo[TIFFCount].NumbersInPixel := DirTIFF;
      TIFFinfo[TIFFCount].LengthBands    := DirTIFF;
      TIFFinfo[TIFFCount].PixelsX        := DirTIFF;
      TIFFinfo[TIFFCount].PixelsY        := DirTIFF;
      TIFFinfo[TIFFCount].Planar         := DirTIFF;
      TIFFinfo[TIFFCount].UnitLength     := DirTIFF;
      TIFFinfo[TIFFCount].DataPoint      := DirTIFF;
      TIFFinfo[TIFFCount].Palette        := DirTIFF;
      for i:=1 to Count do
        begin
          System.BlockRead(f,DirTIFF,12);
          if Info.SwapBytes then
            begin
              DirTIFF.Kategory:=Swap(DirTIFF.Kategory);
              DirTIFF.TypeDate:=Swap(DirTIFF.TypeDate);
              Swap4(DirTIFF.Count);
              if (DirTIFF.TypeDate=3) and (DirTIFF.Count=1) {word}
                then Swap2(DirTIFF.Value)
                else Swap4(DirTIFF.Value);
            end;
          case DirTIFF.Kategory of
            $100: TIFFinfo[TIFFCount].Width          := DirTIFF;
            $101: TIFFinfo[TIFFCount].Height         := DirTIFF;
            $102: TIFFinfo[TIFFCount].Bits           := DirTIFF;
            $103: TIFFinfo[TIFFCount].Compress       := DirTIFF;
            $106: TIFFinfo[TIFFCount].TypeImg        := DirTIFF;
            $116: TIFFinfo[TIFFCount].LinesInBand    := DirTIFF;
            $115: TIFFinfo[TIFFCount].NumbersInPixel := DirTIFF;
            $117: TIFFinfo[TIFFCount].LengthBands    := DirTIFF;
            $11A: TIFFinfo[TIFFCount].PixelsX        := DirTIFF;
            $11B: TIFFinfo[TIFFCount].PixelsY        := DirTIFF;
            $11C: TIFFinfo[TIFFCount].Planar         := DirTIFF;
            $128: TIFFinfo[TIFFCount].UnitLength     := DirTIFF;
            $111: TIFFinfo[TIFFCount].DataPoint      := DirTIFF;
            $140: TIFFinfo[TIFFCount].Palette        := DirTIFF;
          end{case};
              end;
      System.BlockRead(f,PointDir,4);
      if Info.SwapBytes then Swap4(PointDir);
    end;
  System.Close(f);
  Info.OK:=true;
  Info.Error:='';
  Info.FileName:=FileName;
  Info.ImgWidth  :=TIFFinfo[1].Width.Value;   // pokud je to MultiTIFF ctu jen prvni
  Info.ImgHeight :=TIFFinfo[1].Height.Value;
  Info.HeaderSize:=TIFFinfo[1].DataPoint.Value;
  if (TIFFinfo[1].Compress.Value<>1) and (TIFFinfo[1].Compress.Value<>0) then
    begin
      Info.OK:=false;
      Info.Error:='File: '+ExtractFileName(FileName)+ '  has compressed data type. Compression is not supported.';
      if DisplayWarnings then ShowMessage(Info.Error);
      Exit;
    end;
 // if Info.SwapBytes then TIFFinfo[1].TypeImg.Value:=TIFFinfo[1].TypeImg.Value div 65535;
  case TIFFinfo[1].TypeImg.Value of
      0,1 : Info.Channels:=1;
      2   : Info.Channels:=TIFFinfo[1].NumbersInPixel.Value;
      3   : begin
              Info.Channels:=1; // paletovy 8 bit obr.
            end;
    else
      Info.OK:=false;
      Info.Error:='File: '+ExtractFileName(FileName)+ '  has unsupported data type.';
      if DisplayWarnings then ShowMessage(Info.Error);
      Exit;
    end{case};
  if TIFFinfo[1].Bits.Count=3 then
    begin
      System.Assign(f,FileName);
      System.Reset(f,1);
      System.Seek(f,TIFFinfo[1].Bits.Value);
      System.BlockRead(f,RGBbits,6);
      if Info.SwapBytes then for n:=0 to 2 do RGBbits[n]:=swap(RGBbits[n]);
      System.Close(f);
      if (RGBbits[0]=RGBbits[1]) and (RGBbits[1]=RGBbits[2]) then TIFFinfo[1].Bits.Value:=RGBbits[0];
    end;

  if TIFFinfo[1].DataPoint.Count>1 then
  begin
      System.Assign(f,FileName);
      System.Reset(f,1);
      System.Seek(f,TIFFinfo[1].DataPoint.Value);
      System.BlockRead(f,ImgOffset,4);
      if Info.SwapBytes then Swap4(ImgOffset);
      System.Close(f);
      Info.HeaderSize:=ImgOffset;
    end;

  case  TIFFinfo[1].Bits.Value  of
    8 : begin
          Info.DataType:='BYTE';
          Info.BytesPerPixel:=Info.Channels;
        end;
   16 : begin
          Info.DataType:='WORD';
          Info.BytesPerPixel:=Info.Channels*2;
        end;
   else
      Info.OK:=false;
      Info.Error:='File: '+ExtractFilename(FileName)+ '  has unsupported data format ('+IntToStr(TIFFinfo[1].Bits.Value)+' bit).';
      if DisplayWarnings then ShowMessage(Info.Error);
      Exit;
    end{case};
  Info.PixelType:=Info.DataType;
  Info.ImgSize:=Info.ImgWidth*Info.ImgHeight*Info.BytesPerPixel;
 // Info.HeaderSize:=TIFFinfo[1].DataPoint.Value;
  Info.RGBsepatated:=false;
  Info.VertFlip:=false;
  Info.BZero:=0;    // nepouziva se u TIFFu
  Info.BScale:=1;   // nepouziva se u TIFFu
  Info.DataMin:=1;  // nepouziva se u TIFFu
  Info.DataMax:=-1; // nepouziva se u TIFFu
  Info.BitMap:=nil;
end;

procedure WriteTIFFHeaderGray(S: Integer; Width,Height,Bits: Cardinal; Scale: Real; Closing: Boolean);
var RC,RJ,NextPicture: Cardinal;
    Offset       : Longint;
begin
  Offset:=FileSeek(S,0,2);
  TIFFWidth[2]:=Width;
  TIFFHeight[2]:=Height;
  TIFFBits[1]:=1;
  if Bits>8 then
    begin
      TIFFBits[2]:=16;
    end
  else
    begin
      TIFFBits[2]:=8;
    end;
  TIFFTypeImage[2]:=1;
  TIFFCountPar:=12;
  TIFFLinesInBand[2]:=Height;
  TIFFNumbersInPixel[2]:=1;
  if Bits>8 then TIFFLengthBands[2]:=Width*Height*2
  else TIFFLengthBands[2]:=Width*Height;
  TIFFPixelsX[2]:=Offset+158;
  TIFFPixelsY[2]:=Offset+166;
  TIFFDataPoint[2]:=Offset+174;
  FileWrite(s,TIFFHeader,8);
  FileWrite(s,TIFFCountPar,2);
  FileWrite(s,TIFFWidth,12);
  FileWrite(s,TIFFHeight,12);
  FileWrite(s,TIFFBits,12);
  FileWrite(s,TIFFCompress,12);
  FileWrite(s,TIFFTypeImage,12);
  FileWrite(s,TIFFLinesInBand,12);
  FileWrite(s,TIFFNumbersInPixel,12);
  FileWrite(s,TIFFLengthBands,12);
  FileWrite(s,TIFFPixelsX,12);
  FileWrite(s,TIFFPixelsY,12);
  FileWrite(s,TIFFUnitLength,12);
  FileWrite(s,TIFFDataPoint,12);
  if Closing then FileWrite(s,Null,4)
  else
    begin
      NextPicture:=Offset+174+TIFFLengthBands[2]+8;
      FileWrite(s,NextPicture,4);
    end;
  (* zapis meritka - nezapisuje se*)
  RC:=1;
  RJ:=1;
  FileWrite(s,RC,4);
  FileWrite(s,RJ,4);
  FileWrite(s,RC,4);
  FileWrite(s,RJ,4);
end;

procedure WriteTIFFHeaderRGB(S: Integer; Width,Height,Bits: Cardinal; Scale: Real; Closing: Boolean);
var RC,RJ,NextPicture: Cardinal;
    Offset: Longint;
    Bity: Word;
begin
  Offset:=FileSeek(S,0,2);
  TIFFWidth[2]:=Width;
  TIFFHeight[2]:=Height;
  TIFFBits[2]:=Offset+170;
  TIFFBits[1]:=3;
  if Bits>8 then
    begin
      Bity:=16;
      TIFFLengthBands[2]:=Width*Height*6;
    end
  else
    begin
      TIFFLengthBands[2]:=Width*Height*3;
      Bity:=8
    end;
  TIFFCountPar:=13;
  TIFFTypeImage[2]:=2;
  TIFFLinesInBand[2]:=Height;
  TIFFNumbersInPixel[2]:=3;
  TIFFPixelsX[2]:=Offset+176;
  TIFFPixelsY[2]:=Offset+184;
  TIFFDataPoint[2]:=Offset+192;
  FileWrite(s,TIFFHeader,8);
  FileWrite(s,TIFFCountPar,2);
  FileWrite(s,TIFFWidth,12);
  FileWrite(s,TIFFHeight,12);
  FileWrite(s,TIFFBits,12);
  FileWrite(s,TIFFCompress,12);
  FileWrite(s,TIFFTypeImage,12);
  FileWrite(s,TIFFLinesInBand,12);
  FileWrite(s,TIFFNumbersInPixel,12);
  FileWrite(s,TIFFLengthBands,12);
  FileWrite(s,TIFFPixelsX,12);
  FileWrite(s,TIFFPixelsY,12);
  FileWrite(s,TIFFPlanar,12);
  FileWrite(s,TIFFUnitLength,12);
  FileWrite(s,TIFFDataPoint,12);
  if Closing then FileWrite(s,Null,4)
  else
    begin
      NextPicture:=Offset+192+TIFFLengthBands[2]+8;
      FileWrite(s,NextPicture,4);
    end;
  FileWrite(s,Bity,2);
  FileWrite(s,Bity,2);
  FileWrite(s,Bity,2);
  (* zapis meritka - nezapisuje se*)
  RC:=1;
  RJ:=1;
  FileWrite(s,RC,4);
  FileWrite(s,RJ,4);
  FileWrite(s,RC,4);
  FileWrite(s,RJ,4);
end;


procedure ImageToTIFF16(P: Pointer; IW,IH: Integer; Gray: Boolean; SaveFile: String);
var s: Integer;
begin
  s:=FileCreate(SaveFile);
  if Gray then
    begin
      WriteTIFFHeaderGray(s,IW,IH,16,1,True);
      FileWrite(s,P^,IW*IH*2);
    end else
    begin
      WriteTIFFHeaderRGB(s,IW,IH,16,1,True);
      FileWrite(s,P^,IW*IH*6);
    end;
  FileClose(s);
end;


procedure ImageToTIFF8(P: Pointer; IW,IH: Integer; Gray: Boolean; SaveFile: String);
var s: Integer;
begin
  s:=FileCreate(SaveFile);
  if Gray then
    begin
      WriteTIFFHeaderGray(s,IW,IH,8,1,True);
      FileWrite(s,P^,IW*IH);
    end else
    begin
      WriteTIFFHeaderRGB(s,IW,IH,8,1,True);
      FileWrite(s,P^,IW*IH*3);
    end;
  FileClose(s);
end;

procedure ImageToTIFF8ROI(P: Pointer; IW,IH, RoiL,RoiT,RoiW,RoiH : integer; Gray: Boolean; SaveFile: String);
var s, j  : Integer;
    PW    : PWordArr;
    PWC   : PWColorArr;
begin
  PW:=P;
  PWC:=P;
  s:=FileCreate(SaveFile);
  if Gray then
    begin
      WriteTIFFHeaderGray(s,RoiW,RoiH,8,1,True);
      for j:=0 to RoiH-1 do FileWrite(s,PW^[RoiL+RoiT*IW],RoiW);
    end else
    begin
      WriteTIFFHeaderRGB(s,IW,IH,8,1,True);
      for j:=0 to RoiH-1 do FileWrite(s,PWC^[RoiL+RoiT*IW],RoiW*3);
    end;
  FileClose(s);
end;


end.
------------------------------------------

procedure ImageToTIFF16(P: Pointer; IW,IH: Integer; Gray: Boolean; SaveFile: String);
var i,j,k: Word;
    s: Integer;
    SL: PByteArray;
    Line: Array[0..30000] of Word;
    BLine: Array[0..30000] of Byte;
    IA: PWordArray;
    Adr1,Adr2: Longint;
begin
  IA:=P;
  try
    s:=FileCreate(SaveFile);
    if Gray then
      begin
        WriteTIFFHeaderGray(s,IW,IH,16,1,True);
        for j:=0 to IH-1 do
          begin
            for i:=0 to IW-1 do
              Line[i]:=IA^[i+j*IW];
            FileWrite(s,Line,IW*2);
          end;
      end
    else
      begin
        WriteTIFFHeaderRGB(s,IW,IH,16,1,True);
        for j:=0 to IH-1 do
          begin
            for i:=0 to IW-1 do
              for k:=0 to 2 do
                Line[i*3+k]:=IA^[(i+j*IW)*3+2-k];
            FileWrite(s,Line,IW*6);
          end;
      end;
    try
      finally
        FileClose(s);
      end;
    except
      on EInOutError do
        begin
//          EInOutMsg;
          Exit;
        end;
      else
        begin
//          EElseMsg;
          Exit;
        end;
    end;
end;





end.
