unit OpenTIFF;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, JPEG, ClipBrd ;

const
  tbNoMessage = 255;

  imNo     = 0;
  imPalette = 11;
  imInvertGray = 12;

  cmSum = 1;
  cmDisjunction = 2;
  cmConjunction = 3;
  cmRelief = 4;

  (* >>> NELZE ZMENIT >>> *)
  imGrayRed     = 13;
  imGray10Red   = 23;
  imGray12Red   = 33;
  imGray14Red   = 43;
  imGray16Red   = 53;
  imGrayGreen   = 14;
  imGray10Green = 24;
  imGray12Green = 34;
  imGray14Green = 44;
  imGray16Green = 54;
  imGrayBlue    = 15;
  imGray10Blue  = 25;
  imGray12Blue  = 35;
  imGray14Blue  = 45;
  imGray16Blue  = 55;
  imGray16Sat   = 56;
  imGray16Bright = 57;
  imAny = 0;
  imGray   = 1;
  imGray10 = 2;
  imGray12 = 3;
  imGray14 = 4;
  imGray16 = 5;
  imRGB   = 6;
  imRGB10 = 7;
  imRGB12 = 8;
  imRGB14 = 9;
  imRGB16 = 10;
  imRGB16Hue = 68;
  imGrayLH = 11;
  imRGBLH = 12;
  imGray32R = 17;
  (* <<< NELZE ZMENIT <<< *)

var
  CompTab: Array[1..10,1..10] of Integer = (( 1, 2, 3, 4, 5, 6, 7, 8, 9,10),
                                         ( 2, 2, 3, 4, 5, 7, 7, 8, 9,10),
                                         ( 3, 3, 3, 4, 5, 8, 8, 8, 9,10),
                                         ( 4, 4, 4, 4, 5, 9, 9, 9, 9,10),
                                         ( 5, 5, 5, 5, 5,10,10,10,10,10),
                                         ( 6, 7, 8, 9,10, 6, 7, 8, 9,10),
                                         ( 7, 7, 8, 9,10, 7, 7, 8, 9,10),
                                         ( 8, 8, 8, 9,10, 8, 8, 8, 9,10),
                                         ( 9, 9, 9, 9,10, 9, 9, 9, 9,10),
                                         (10,10,10,10,10,10,10,10,10,10));

  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);
  Null: Cardinal = $00000000;


type
  TSWAP32 = record
              B1,B2,B3,B4: Byte;
            end;
  TArraySWAP32 = Array[0..16000*16000] of TSWAP32;
  PArraySWAP32 = ^TArraySWAP32;
  TArray = Array[0..32000*32000] of Byte;
  PArray = ^TArray;
  TWordArray = Array[0..32000*32000] of Word;
  PWordArray = ^TWordArray;
  TSingleArray = Array[0..16000*16000] of Single;
  PSingleArray = ^TSingleArray;
  THeaderDIPS = Array[0..6] of AnsiChar;
  TBMPPalette = Array[0..255] of record
                                   Blue,Green,Red: Byte;
                                 end;
  THeaderTIFF = Array[0..3] of AnsiChar;
  TDirTIFF = record
               Kategory: Word;
               TypeDate: Word;
               Count: Cardinal;
               Value: Cardinal;
             end;
  TTIFFinfo = Array[1..255] of
                record
                  Width,Height,Bits,Compress,TypeImg,LinesInBand,NumbersInPixel,
                  LengthBands,PixelsX,PixelsY,Planar,UnitLength,DataPoint,Palette: TDirTIFF;
                end;
  TIndexes = Array[1..255] of Boolean;
  TFTSinfo = record
               Width,Height,TypeImage: Integer;
               Size: Longint;
               DataOffSet: Longint;
             end;
  TImage8ArrayRGB = Array[0..3*10000*10000] of Byte;
  PImage8ArrayRGB = ^TImage8ArrayRGB;
  TImage8ArrayGray = Array[0..10000*10000] of Byte;
  PImage8ArrayGray = ^TImage8ArrayGray;
  TImage16ArrayRGB = Array[0..3*10000*10000] of Word;
  PImage16ArrayRGB = ^TImage16ArrayRGB;
  TImage16ArrayGray = Array[0..10000*10000] of Word;
  PImage16ArrayGray = ^TImage16ArrayGray;
  TImage32ArrayGray = Array[0..10000*10000] of Longint;
  PImage32ArrayGray = ^TImage32ArrayGray;
  TImage32ArrayRGB = Array[0..3*10000*10000] of Longint;
  PImage32ArrayRGB = ^TImage32ArrayRGB;
  TImage16ArraySInt = Array[0..10000*10000] of Smallint;
  PImage16ArraySInt = ^TImage16ArraySInt;
  TImageSingleArray = Array[0..3*10000*10000] of Single;
  PImageSingleArray = ^TImageSingleArray;
  TLineByte = Array[0..5*10000] of Byte;
  PLineByte = ^TLineByte;
  TLineWord = Array[0..5*10000] of Word;
  PLineWord = ^TLineWord;
  TLineInteger = Array[0..5*10000] of SmallInt;
  PLineInteger = ^TLineInteger;
  TLineLongint = Array[0..5*10000] of Longint;
  PLineLongint = ^TLineLongint;
  Rational = record
               C,J: Cardinal;
             end;
  TBIFFormat = record
                 ID,EID,FileName,Order: AnsiString;
                 Width,Height,Header,Channels,LeftPAdding,RightPAdding: Longint;
                 DataType,DataMask,ByteOrder: AnsiString;
                 Scale: Real;
               end;

const
  CHeaderDIG : THeaderDIPS = ('P','H','S','-','A','r','r');
  CHeaderTIFF : THeaderTIFF = ('I','I',#$2A,#0);
  MACHeaderTIFF : THeaderTIFF = ('M','M',#0,#$2A);

var
  TIFFinfo: TTIFFinfo;
  TIFFCount: Byte;
  TypeTIFF: Integer;
  GrayBits, RedBits, GreenBits, BlueBits: Word;
  DT,DL: Cardinal;
  ImageScale: Real;
  UpperValue: Longint;
  ByteArray: PLineByte;
  WordArray: PLineWord;
  LongintArray: PLineLongint;

function TestTIFFile(FileName: AnsiString; var TIFFinfo: TTIFFinfo): Boolean;
function LengthTIFFTypeDate(TD: Word): Byte;
function GetTIFFData(FA: PArray; DirTIFF: TDirTIFF; var V; LV,Index: Integer): Boolean;
function GetTIFFTypeImage(TIFFinfo: TTIFFinfo; Index: Byte): Integer;
function TypeRGB(TypeImage: Integer): Boolean;
function TypeHighRGB(TypeImage: Integer): Boolean;
function TypeGray(TypeImage: Integer): Boolean;
function TypeHighGray(TypeImage: Integer): Boolean;
function UpperValueImage(TypeImage: Integer): Longint;
function BitsInPixel(TypeImage: Integer): Byte;
function Test8BitGrayPalette(BMP: TBitmap): Boolean;
function GetNameFromTypeImage(TypeImage: Integer): AnsiString;
procedure GetTypeImageFromName(Name: AnsiString; var TypeImage: Integer);
procedure Swap4(var C: Cardinal);
procedure Swap2(var W: Word);
function GetFileSize(FileName: AnsiString): Longint;
procedure TIFToSingle(FileName: TFileName; var ImageSingleArray: PImageSingleArray;
                      var ImageDX,ImageDY: Integer; var GRGB: AnsiString);
procedure WriteTIFFHeaderGray(S: Integer; Width,Height,Bits: Cardinal; Scale: Real; Closing: Boolean);
procedure WriteTIFFHeaderRGB(S: Integer; Width,Height,Bits: Cardinal; Scale: Real; Closing: Boolean);
function GetTypeTIFFGray(Value: Word): Integer;
function GetTypeTIFFRGB(Value: Word): Integer;
function GetTIFFFileData(TIFFFile: Integer; DirTIFF: TDirTIFF; var V; LV,Index: Integer): Boolean;
function GetTIFFWidth(TIFFinfo: TTIFFinfo; Index: Byte): Integer;
function GetTIFFHeight(TIFFinfo: TTIFFinfo; Index: Byte): Integer;
function get_png_info(name: PAnsiChar; xres: PInt; yres: PInt; bpp: PInt; is_gray: PInt): Integer; cdecl;
function load_png_rgb16(name: PAnsiChar; data: Pointer; xres: PInt; yres: PInt; P: Pointer): Integer; cdecl;
function load_png_gray16(name: PAnsiChar; data: Pointer; xres: PInt; yres: PInt; P: Pointer): Integer; cdecl;
function load_png_rgb8(name: PAnsiChar; data: Pointer; xres: PInt; yres: PInt; P: Pointer): Integer; cdecl;
function load_png_gray8(name: PAnsiChar; data: Pointer; xres: PInt; yres: PInt; P: Pointer): Integer; cdecl;
function save_png_rgb8(mem: Pointer; xres,yres: Integer; name: PAnsiChar): integer cdecl;
function save_png_rgb16(mem: Pointer; xres,yres: Integer; name: PAnsiChar): integer cdecl;
function save_png_gray8(mem: Pointer; xres,yres: Integer; name: PAnsiChar): integer cdecl;
function save_png_gray16(mem: Pointer; xres,yres: Integer; name: PAnsiChar): integer cdecl;
procedure LoadFromFileTIF(FileName: TFileName; Index: Integer; var Image16Array: PImage16ArrayRGB; var TIFFinfo: TTIFFinfo);
procedure LoadFromFilePNG(FileName: TFileName; var Width,Height,TI: Integer; var Data: Pointer);
procedure ImageToTIFF8(BMP: TBitmap; SaveFile: AnsiString);
procedure ImageToTIFF16(P: Pointer; IW,IH: Integer; Gray: Boolean; SaveFile: AnsiString);


implementation

function get_png_info(name: PAnsiChar; xres: PInt; yres: PInt; bpp: PInt; is_gray: PInt): Integer; external 'loadpng.dll';
function load_png_rgb16(name: PAnsiChar; data: Pointer; xres: PInt; yres: PInt; P: Pointer): Integer; external 'loadpng.dll';
function load_png_gray16(name: PAnsiChar; data: Pointer; xres: PInt; yres: PInt; P: Pointer): Integer; external 'loadpng.dll';
function load_png_rgb8(name: PAnsiChar; data: Pointer; xres: PInt; yres: PInt; P: Pointer): Integer; external 'loadpng.dll';
function load_png_gray8(name: PAnsiChar; data: Pointer; xres: PInt; yres: PInt; P: Pointer): Integer; external 'loadpng.dll';
function save_png_rgb8; external 'libpng.dll';
function save_png_rgb16; external 'libpng.dll';
function save_png_gray8; external 'libpng.dll';
function save_png_gray16; external 'libpng.dll';

function GetFileSize(FileName: AnsiString): Longint;
var f: Integer;
    Pos: Integer;
begin
  GetFileSize:=0;
  try
    f:=FileOpen(FileName,fmOpenRead);
    Pos:=SysUtils.FileSeek(f,0,2);
    try
      finally
        GetFileSize:=Pos;
        FileClose(f);
      end;
  except
  end;
end;

function TestTIFFile(FileName: AnsiString; var TIFFinfo: TTIFFinfo): Boolean;
var F: Integer;
    TTF: Boolean;
    Count: Word;
    PointDir: Cardinal;
    i: Word;
    DirTIFF: TDirTIFF;
    HeaderTIFF: THeaderTIFF;
begin
  if not FileExists(FileName) then
    begin
      TestTIFFile:=False;
      Exit;
    end;
(*  System.Assign(f,FileName);*)
  try
    F:=FileOpen(FileName,fmOpenRead);
(*    System.Reset(f,1);*)
    FileRead(f,HeaderTIFF,4);
    if HeaderTIFF=CHeaderTIFF then
      begin
        TTF:=True;
        FileRead(f,PointDir,4);
        TIFFCount:=0;
        while PointDir<>0 do
          begin
            Inc(TIFFCount);
            FileSeek(f,PointDir,0);
            FileRead(f,Count,2);

            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
                FileRead(f,DirTIFF,12);
                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;
              end;
            FileRead(f,PointDir,4);
          end;
      end
{    else
    if HeaderTIFF=MACHeaderTIFF then
      begin
        TTF:=True;
        FileRead(f,PointDir,4);
        Swap4(PointDir);
        TIFFCount:=0;
        while PointDir<>0 do
          begin
            Inc(TIFFCount);
            FileSeek(f,PointDir,0);
            FileRead(f,Count,2);
            Swap2(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
                FileRead(f,DirTIFF,12);
                Swap2(DirTIFF.Kategory);
                Swap2(DirTIFF.TypeDate);
                Swap4(DirTIFF.Count);
                Swap4(DirTIFF.Value);
                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;
              end;
            FileRead(f,PointDir,4);
            Swap4(PointDir);
          end;
      end}
    else TTF:=False;
    try
      finally
        FileClose(f);
      end;
  except
    ShowMessage(FileName+' isn`t TIFF file');
    TTF:=False;
  end;
  TestTIFFile:=TTF;
end;



function LengthTIFFTypeDate(TD: Word): Byte;
var LTTD: Byte;
begin
  LTTD:=1;
  case TD of
    1: LTTD:=1;
    2: LTTD:=1;
    3: LTTD:=2;
    4: LTTD:=4;
    5: LTTD:=8;
  end;
  LengthTIFFTypeDate:= LTTD;
end;

function GetTIFFData(FA: PArray; DirTIFF: TDirTIFF; var V; LV,Index: Integer): Boolean;
var LengthV: Word;
    i,LengthData: Word;
    P: Pointer;
    ByteArray: PByteArray;
    GTD: Boolean;
    HArray: Array[0..15] of Byte;
const VC : Longint = 0;
begin;
  GetTIFFData:=False;
  for i:=0 to 15 do
    HArray[i]:=0;
  if DirTIFF.Kategory=0 then
    begin
      P:=@HArray;
      Move(P^,V,LV);
      GetTIFFData:=False;
    end;
  LengthV:=LengthTIFFTypeDate(DirTIFF.TypeDate);
  if LengthV>LV then Exit;
  if Index>=DirTIFF.Count then Exit;
  LengthData:=LengthV*DirTIFF.Count;
  if LengthData<=4 then
    begin
      ByteArray:=Addr(DirTIFF.Value);
      P:=@ByteArray[Index*LV];
      Move(P^,HArray,LengthV);
      Move(HArray,V,LV);
      GTD:=True;
    end
  else
    begin
      P:=@FA[DirTIFF.Value+Index*LV];
      Move(P^,HArray,LengthV);
      Move(HArray,V,LV);
      GTD:=True;
    end;
  GetTIFFData:=GTD;
end;

function GetTIFFTypeImage(TIFFinfo: TTIFFinfo; Index: Byte): Integer;
var TY,TI: Word;
begin
  TI:=imNo;
  TY:=TIFFinfo[Index].TypeImg.Value;
  if ((TY=0) or (TY=1)) then TI:=imGray;
  if TY=2 then TI:=imRGB;
  if TY=3 then TI:=imPalette;
  if TIFFinfo[1].Compress.Value<>1 then TI:=imNo;
  GetTIFFTypeImage:=TI;
end;

function GetTIFFWidth(TIFFinfo: TTIFFinfo; Index: Byte): Integer;
var TY: Word;
begin
  TY:=TIFFinfo[Index].Width.Value;
  GetTIFFWidth:=TY;
end;

function GetTIFFHeight(TIFFinfo: TTIFFinfo; Index: Byte): Integer;
var TY: Word;
begin
  TY:=TIFFinfo[Index].Height.Value;
  GetTIFFHeight:=TY;
end;

function TypeRGB(TypeImage: Integer): Boolean;
begin
  TypeRGB:=(TypeImage=imRGB) or TypeHighRGB(TypeImage);
end;

function TypeHighRGB(TypeImage: Integer): Boolean;
begin
  TypeHighRGB:=(TypeImage=imRGB10) or (TypeImage=imRGB12) or
     (TypeImage=imRGB14) or (TypeImage=imRGB16);
end;

function TypeGray(TypeImage: Integer): Boolean;
begin
  TypeGray:=(TypeImage=imGray) or TypeHighGray(TypeImage);
end;

function TypeHighGray(TypeImage: Integer): Boolean;
begin
  TypeHighGray:=(TypeImage=imGray10) or (TypeImage=imGray12) or
     (TypeImage=imGray14) or (TypeImage=imGray16);
end;

function UpperValueImage(TypeImage: Integer): Longint;
begin
  UpperValueImage:=255;
  case TypeImage of
    imGray:   UpperValueImage:=255;
    imGray10: UpperValueImage:=1023;
    imGray12: UpperValueImage:=4095;
    imGray14: UpperValueImage:=16383;
    imGray16: UpperValueImage:=65535;
    imRGB:   UpperValueImage:=255;
    imRGB10: UpperValueImage:=1023;
    imRGB12: UpperValueImage:=4095;
    imRGB14: UpperValueImage:=16383;
    imRGB16: UpperValueImage:=65535;
  end;
end;

function BitsInPixel(TypeImage: Integer): Byte;
begin
  BitsInPixel:=8;
  case TypeImage of
    imGray:   BitsInPixel:=8;
    imGray10: BitsInPixel:=10;
    imGray12: BitsInPixel:=12;
    imGray14: BitsInPixel:=14;
    imGray16: BitsInPixel:=16;
    imRGB:   BitsInPixel:=8;
    imRGB10: BitsInPixel:=10;
    imRGB12: BitsInPixel:=12;
    imRGB14: BitsInPixel:=14;
    imRGB16: BitsInPixel:=16;
  end;
end;

function TestFTSFile(FileName: AnsiString; var FTSinfo: TFTSinfo): Boolean;
var F: File;
    FTS: Boolean;
    i,j,k,C: Word;
    Size: Longint;
    Row: Array[0..79] of AnsiChar;
    Ret: Array[1..40] of AnsiString;
    Value: Real;
    S: AnsiString;
    io,Bits: Integer;
    B: Byte;
begin
  if not FileExists(FileName) then
    begin
      TestFTSFile:=False;
      Exit;
    end;
  System.Assign(f,FileName);
  FTS:=True;
  try
    System.Reset(f,1);
    Size:=System.FileSize(f);
    FTSinfo.Width:=0;
    FTSinfo.Height:=0;
    FTSinfo.TypeImage:=imNo;
    FTSinfo.Size:=Size;
    repeat
      for k:=1 to 40 do Ret[k]:='';
      C:=0;
      S:='';
      System.BlockRead(f,Row,80);
      for j:=0 to 79 do
        begin
          if (Row[j]<>' ') then S:=S+Row[j];
          if (Row[j]=' ') and (S<>'') then
            begin
              Inc(C);
              Ret[C]:=S;
              S:='';
            end;
        end;
      if (Ret[1]='NAXIS1') and (Ret[2]='=') then
        begin
          System.Val(Ret[3],Value,io);
          FTSinfo.Width:=Round(Value);
        end;
      if (Ret[1]='NAXIS2') and (Ret[2]='=') then
        begin
          System.Val(Ret[3],Value,io);
          FTSinfo.Height:=Round(Value);
        end;
      if (Ret[1]='BITPIX') and (Ret[2]='=') then
        begin
          System.Val(Ret[3],Value,io);
          Bits:=Round(Value);
          case Bits of
            8:FTSinfo.TypeImage:=imGray;
           10:FTSinfo.TypeImage:=imGray10;
           12:FTSinfo.TypeImage:=imGray12;
           14:FTSinfo.TypeImage:=imGray14;
           16:FTSinfo.TypeImage:=imGray16;
          -32:FTSinfo.TypeImage:=imGray32R;
          end;
        end;
    until Ret[1]='END';
    FTSinfo.DataOffSet:=System.FilePos(f);
    if Frac(FTSinfo.DataOffSet/2880)>0 then
      FTSinfo.DataOffSet:=(Trunc(FTSinfo.DataOffSet/2880)+1)*2880;
    try
      finally
        System.Close(f);
      end;
  except
    FTS:=False;
  end;
  TestFTSFile:=FTS;
end;


function Test8BitGrayPalette(BMP: TBitmap): Boolean;
var Col,Red,Green,Blue: Byte;
    i: Integer;
    Data: Longint;
    SL: PByteArray;
begin
  Test8BitGrayPalette:=True;
  if BMP.PixelFormat<>pf8bit then
    begin
      Test8BitGrayPalette:=False;
      Exit;
    end;
  SL:=BMP.ScanLine[0];
  Col:=SL[0];
  for i:=0 to 255 do
    begin
      SL[0]:=i;
      Data:=BMP.Canvas.Pixels[0,0];
      Red:=Data mod 256;
      Green:=Trunc(Data/256) mod 256;
      Blue:=Trunc(Data/65536);
      if (Red<>Green) or (Green<>Blue) then Test8BitGrayPalette:=False;
    end;
  SL[0]:=Col;
end;

procedure Swap4(var C: Cardinal);
var Pole: PArray;
    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;
end;

procedure Swap2(var W: Word);
var Pole: PArray;
    B: Byte;
begin
  Pole:=@W;
  B:=Pole[0];
  Pole[0]:=Pole[1];
  Pole[1]:=B;
end;

function GetNameFromTypeImage(TypeImage: Integer): AnsiString;
begin
  case TypeImage of
    1: GetNameFromTypeImage:='imGray';
    2: GetNameFromTypeImage:='imGray10';
    3: GetNameFromTypeImage:='imGray12';
    4: GetNameFromTypeImage:='imGray14';
    5: GetNameFromTypeImage:='imGray16';
    6: GetNameFromTypeImage:='imRGB';
    7: GetNameFromTypeImage:='imRGB10';
    8: GetNameFromTypeImage:='imRGB12';
    9: GetNameFromTypeImage:='imRGB14';
    10: GetNameFromTypeImage:='imRGB16';
    68: GetNameFromTypeImage:='imRGB16';
    56: GetNameFromTypeImage:='imGray16';
    57: GetNameFromTypeImage:='imGray16';
  end;
end;

procedure GetTypeImageFromName(Name: AnsiString; var TypeImage: Integer);
begin
  if Name='imGray' then TypeImage:=1 ;
  if Name='imGray10' then TypeImage:=2 ;
  if Name='imGray12' then TypeImage:=3 ;
  if Name='imGray14' then TypeImage:=4 ;
  if Name='imGray16' then TypeImage:=5 ;
  if Name='imRGB' then TypeImage:=6 ;
  if Name='imRGB10' then TypeImage:=7 ;
  if Name='imRGB12' then TypeImage:=8 ;
  if Name='imRGB14' then TypeImage:=9 ;
  if Name='imRGB16' then TypeImage:=10 ;
  if Name='imRGB16Hue' then TypeImage:=68;
  if Name='imGray16Sat' then TypeImage:=56;
  if Name='imGray16Bright' then TypeImage:=57;
end;

procedure Register;
begin
end;

procedure TIFToSingle(FileName: TFileName; var ImageSingleArray: PImageSingleArray;
                                 var ImageDX,ImageDY: Integer; var GRGB: AnsiString);
var TIFFinfo: TTIFFinfo;
    i,j,jj,k,l: Longint;
    s: Integer;
    Size,Min,Max: Longint;
    FileArray: PArray;
    B: Array[0..32000] of Byte;
    P,P1,P2: Pointer;
    ww,DXB,TY,TYZal,UL,NIP,Planar,Comp,DPC,Pal: Word;
    DX,DY,DXZal,DYZal,LIB,LB,DP: Cardinal;
    PX,PY,PXZal,PYZal: Rational;
    AddrPA,AddrFA,DL: Longint;
    BPal: Byte;
    WPal: Word;
    LineWord: PLineWord;
    Index,Ind: Byte;
    TypeTIFF: Integer;
    GrayBits, RedBits, GreenBits, BlueBits: Word;
begin
  TestTIFFile(FileName,TIFFinfo);
  Size:=GetFileSize(FileName);
  Index:=1;
  try
    GetMem(FileArray,Size);
    s:=FileOpen(FileName,fmOpenRead);
    FileRead(s,FileArray^,Size);
    GetTIFFData(FileArray,TIFFinfo[Index].Width,DX,4,0);
    GetTIFFData(FileArray,TIFFinfo[Index].Height,DY,4,0);
    GetTIFFData(FileArray,TIFFinfo[Index].PixelsX,PX,8,0);
    GetTIFFData(FileArray,TIFFinfo[Index].PixelsY,PY,8,0);
    GetTIFFData(FileArray,TIFFinfo[Index].TypeImg,TY,2,0);
    DXZal:=DX; DYZal:=DY;
    PXZal:=PX; PYZal:=PY;
    TYZal:=TY;
    GetTIFFData(FileArray,TIFFinfo[Index].NumbersInPixel,NIP,2,0);
    GetTIFFData(FileArray,TIFFinfo[Index].LinesInBand,LIB,4,0);
    if LIB=0 then LIB:=DY;
    GetTIFFData(FileArray,TIFFinfo[Index].UnitLength,UL,2,0);
    GetTIFFData(FileArray,TIFFinfo[Index].Compress,Comp,2,0);
    case TY of
      0:TypeTIFF:=imInvertGray;
      1:TypeTIFF:=imGray;
      2:TypeTIFF:=imRGB;
      3:TypeTIFF:=imPalette;
    end;
    (*********************  GRAY ***************************)
    if (TypeTIFF = imGray) or (TypeTIFF = imInvertGray) then
      begin
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,GrayBits,2,0);
        DPC:=TIFFinfo[Index].DataPoint.Count;
        GetMem(ImageSingleArray,DX*DY*4);
        ImageDx:=DX;
        ImageDy:=DY;
        GRGB:='G';
        (* 8-mi bitovy obraz *)
        if GrayBits=8 then
          begin
            (* Vytvoreni bitmapy *)
            try
              for k:=1 to DPC do
                begin
                  GetTIFFData(FileArray,TIFFinfo[Index].DataPoint,DP,4,k-1);
                  GetTIFFData(FileArray,TIFFinfo[Index].LengthBands,LB,4,k-1);
                  for j:=1 to LIB do
                    begin
                      AddrPA:=((k-1)*LIB+(j-1))*DX;
                      AddrFA:=DP+(j-1)*DX;
                      if Dy>=(k-1)*LIB+j then
                        begin
                          if TypeTIFF = imInvertGray then
                            begin
                              for i:=0 to DX-1 do
                                ImageSingleArray[AddrPA+i]:=255-FileArray[AddrFA+i];
                            end
                          else
                            begin
                              for i:=0 to DX-1 do
                                ImageSingleArray[AddrPA+i]:=FileArray[AddrFA+i];
                            end
                        end;
                    end;
                end;
            try
              finally
              end;
            except
            end;
          end;
        (* 16-ti bitovy obraz *)
        if GrayBits=16 then
          begin
            (* Vytvoreni bitmapy *)
            try
              for k:=1 to DPC do
                begin
                  GetTIFFData(FileArray,TIFFinfo[Index].DataPoint,DP,4,k-1);
                  GetTIFFData(FileArray,TIFFinfo[Index].LengthBands,LB,4,k-1);
                  for j:=1 to LIB do
                    begin
                      jj:=(k-1)*LIB+j-1;
                      if Dy>jj then
                        begin
                          LineWord:=@FileArray[DP+((j-1)*DX)*2];
                          for i:=0 to DX-1 do
                            ImageSingleArray[jj*DX+i]:=LineWord[i];
                        end;
                    end;
                end;
            try
              finally
              end;
            except
            end;
          end;
      end;
    (******************************* RGB *************************)
    if TypeTIFF = imRGB then
      begin
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,RedBits,2,0);
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,GreenBits,2,1);
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,BlueBits,2,2);
        GetTIFFData(FileArray,TIFFinfo[Index].Planar,Planar,2,0);
        GetMem(ImageSingleArray,DX*DY*12);
        ImageDx:=DX;
        ImageDy:=DY;
        GRGB:='RGB';
        (* Vytvoreni bitmapy *)
        DPC:=TIFFinfo[Index].DataPoint.Count;
        (* 8-mi bitovy obraz *)
        if (RedBits=8) and (GreenBits=8) and (BlueBits=8) then
          begin
            for k:=1 to DPC do
              begin
                GetTIFFData(FileArray,TIFFinfo[Index].DataPoint,DP,4,k-1);
                GetTIFFData(FileArray,TIFFinfo[Index].LengthBands,LB,4,k-1);
                for j:=1 to LIB do
                  if Dy>=(k-1)*LIB+j then
                    begin
                      if (Planar=1) or (Planar=1) then
                        begin
                          jj:=(k-1)*LIB+(j-1);
                          for i:=0 to DX-1 do
                            begin
                              AddrPA:=(jj*DX+i)*3;
                              AddrFA:=DP+((j-1)*DX+i)*3;
                              ImageSingleArray[0+AddrPA]:=FileArray[0+AddrFA];
                              ImageSingleArray[1+AddrPA]:=FileArray[1+AddrFA];
                              ImageSingleArray[2+AddrPA]:=FileArray[2+AddrFA];
                            end;
                        end;
                    end;
              end;
          end;

        (* 16-mi bitovy obraz *)
        if (RedBits=16) and (GreenBits=16) and (BlueBits=16) then
          begin
            for k:=1 to DPC do
              begin
                GetTIFFData(FileArray,TIFFinfo[Index].DataPoint,DP,4,k-1);
                GetTIFFData(FileArray,TIFFinfo[Index].LengthBands,LB,4,k-1);
                for j:=1 to LIB do
                  begin
                    jj:=(k-1)*LIB+j-1;
                    if Dy>jj then
                      begin
                        if (Planar=1) or (Planar=0) then
                          begin
                            LineWord:=@FileArray[DP+(j-1)*DX*6];
                            for i:=0 to DX*3-1 do
                              ImageSingleArray[jj*DX*3+i]:=LineWord[i];
                          end;
                      end;
                  end;
              end;
          end;
      end;
    (*********************************** PALETTE ***********************)
    if (NIP=1) and (TypeTIFF=imPalette) then
      begin
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,GrayBits,2,0);
        if GrayBits=16 then
          begin
            GetMem(ImageSingleArray,DX*DY*4);
            ImageDx:=DX;
            ImageDy:=DY;
            GRGB:='G';
(* !!!!! *) (* OLYMPUS TIFF FORMAT *)
//            for Ind:=1 to TIFFCount do
            Ind:=1;
            GetTIFFData(FileArray,TIFFinfo[Ind].Width,DX,4,0);
            GetTIFFData(FileArray,TIFFinfo[Ind].Height,DY,4,0);
            GetTIFFData(FileArray,TIFFinfo[Ind].PixelsX,PX,8,0);
            GetTIFFData(FileArray,TIFFinfo[Ind].PixelsY,PY,8,0);
            GetTIFFData(FileArray,TIFFinfo[Ind].TypeImg,TY,2,0);
            if (DX=DXZal) and (DY=DYZal) and (PX.C=PXZal.C) and (PY.C=PYZal.C) and
               (PX.J=PXZal.J) and (PY.J=PYZal.J) and (TY=TYZal) then
              begin
                GetTIFFData(FileArray,TIFFinfo[Ind].NumbersInPixel,NIP,2,0);
                GetTIFFData(FileArray,TIFFinfo[Ind].LinesInBand,LIB,4,0);
                if LIB=0 then LIB:=DY;
                GetTIFFData(FileArray,TIFFinfo[Ind].UnitLength,UL,2,0);
                GetTIFFData(FileArray,TIFFinfo[Ind].Compress,Comp,2,0);
                DPC:=TIFFinfo[Ind].DataPoint.Count;
                for k:=1 to DPC do
                  begin
                    GetTIFFData(FileArray,TIFFinfo[Ind].DataPoint,DP,4,k-1);
                    GetTIFFData(FileArray,TIFFinfo[Ind].LengthBands,LB,4,k-1);
                    for j:=1 to LIB do
                      begin
                        jj:=(k-1)*LIB+j-1;
                        if Dy>jj then
                          begin
                            LineWord:=@FileArray[DP+((j-1)*DX)*2];
                            for i:=0 to DX-1 do
                              ImageSingleArray[jj*DX+i]:=LineWord[i];
                          end;
                      end;
                  end;
              end;
          end;
      end;
  try
    finally
      FileClose(s);
      FreeMem(FileArray,Size);
    end;
  except
  end;
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;


function GetTypeTIFFGray(Value: Word): Integer;
begin
  GetTypeTIFFGray:=imGray10;
  if Value>=1024 then GetTypeTIFFGray:=imGray12;
  if Value>=4096 then GetTypeTIFFGray:=imGray14;
  if Value>=16384 then GetTypeTIFFGray:=imGray16;
end;

function GetTypeTIFFRGB(Value: Word): Integer;
begin
  GetTypeTIFFRGB:=imRGB10;
  if Value>=1024 then GetTypeTIFFRGB:=imRGB12;
  if Value>=4096 then GetTypeTIFFRGB:=imRGB14;
  if Value>=16384 then GetTypeTIFFRGB:=imRGB16;
end;

function GetTIFFFileData(TIFFFile: Integer; DirTIFF: TDirTIFF; var V; LV,Index: Integer): Boolean;
var LengthV: Word;
    i,LengthData: Word;
    P: Pointer;
    ByteArray: PByteArray;
    GTD: Boolean;
    HArray: Array[0..15] of Byte;
const VC : Longint = 0;
begin;
  GetTIFFFileData:=False;
  for i:=0 to 15 do
    HArray[i]:=0;
  if DirTIFF.Kategory=0 then
    begin
      P:=@HArray;
      Move(P^,V,LV);
      GetTIFFFileData:=False;
    end;
  LengthV:=LengthTIFFTypeDate(DirTIFF.TypeDate);
  if LengthV>LV then Exit;
  if Index>=DirTIFF.Count then Exit;
  LengthData:=LengthV*DirTIFF.Count;
  if LengthData<=4 then
    begin
      ByteArray:=Addr(DirTIFF.Value);
      P:=@ByteArray[Index*LV];
      Move(P^,HArray,LengthV);
      Move(HArray,V,LV);
      GTD:=True;
    end
  else
    begin
      FileSeek(TIFFFile,DirTIFF.Value+Index*LV,0);
//      P:=@FA[DirTIFF.Value+Index*LV];
//      Move(P^,HArray,LengthV);
      FileRead(TIFFFile,HArray,LengthV);
      Move(HArray,V,LV);
      GTD:=True;
    end;
  GetTIFFFileData:=GTD;
end;

procedure LoadFromFileTIF(FileName: TFileName; Index: Integer; var Image16Array: PImage16ArrayRGB; var TIFFinfo: TTIFFinfo);
var i,j,jj,k,l: Longint;
    s: Integer;
    Size,Min,Max: Longint;
    FileArray: PArray;
    HlavickaDIG : THeaderDIPS;
    SL: PByteArray;
    B: Array[0..32000] of Byte;
    P,P1,P2: Pointer;
    ww,DXB,TY,TYZal,UL,NIP,Planar,Comp,DPC,Pal: Word;
    DX,DY,DXZal,DYZal,LIB,LB,DP: Cardinal;
    PX,PY,PXZal,PYZal: Rational;
    WorkFile: AnsiString;
    f: File;
    AddrPA,AddrFA,DL: Longint;
    Palette: TBMPPalette;
    BPal: Byte;
    WPal: Word;
    PomReal: Real;
    Image32ArrayGray: PImage32ArrayGray;
    Ind: Byte;
begin
  TestTIFFile(FileName,TIFFinfo);
  Size:=GetFileSize(FileName);
  if (Index<1) or (Index>TIFFCount) then Exit;
  try
    GetMem(FileArray,Size);
    s:=FileOpen(FileName,fmOpenRead);
    FileRead(s,FileArray^,Size);
    GetTIFFData(FileArray,TIFFinfo[Index].Width,DX,4,0);
    GetTIFFData(FileArray,TIFFinfo[Index].Height,DY,4,0);
    GetTIFFData(FileArray,TIFFinfo[Index].PixelsX,PX,8,0);
    GetTIFFData(FileArray,TIFFinfo[Index].PixelsY,PY,8,0);
    GetTIFFData(FileArray,TIFFinfo[Index].TypeImg,TY,2,0);
    DXZal:=DX; DYZal:=DY;
    PXZal:=PX; PYZal:=PY;
    TYZal:=TY;
    GetTIFFData(FileArray,TIFFinfo[Index].NumbersInPixel,NIP,2,0);
    GetTIFFData(FileArray,TIFFinfo[Index].LinesInBand,LIB,4,0);
    if LIB=0 then LIB:=DY;
    GetTIFFData(FileArray,TIFFinfo[Index].UnitLength,UL,2,0);
    GetTIFFData(FileArray,TIFFinfo[Index].Compress,Comp,2,0);
    case TY of
      0:TypeTIFF:=imInvertGray;
      1:TypeTIFF:=imGray;
      2:TypeTIFF:=imRGB;
      3:TypeTIFF:=imPalette;
    end;
    (*********************  GRAY ***************************)
    if (TypeTIFF = imGray) or (TypeTIFF = imInvertGray) then
      begin
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,GrayBits,2,0);
        DPC:=TIFFinfo[Index].DataPoint.Count;
        if GrayBits=16 then
          begin
            (* Vytvoreni bitmapy *)
            try
              GetMem(Image16Array,DX*DY*2);
              for k:=1 to DPC do
                begin
                  GetTIFFData(FileArray,TIFFinfo[Index].DataPoint,DP,4,k-1);
                  GetTIFFData(FileArray,TIFFinfo[Index].LengthBands,LB,4,k-1);
                  for j:=1 to LIB do
                    begin
                      jj:=(k-1)*LIB+j-1;
                      if Dy>jj then
                        begin
                          P1:=@FileArray[DP+((j-1)*DX)*2];
                          P2:=@Image16Array[jj*DX];
                          Move(P1^,P2^,DX*2);
                        end;
                    end;
                end;
              Max:=-2147483646;
              Min:=2147483646;
              for i:=0 to DX*DY-1 do
                begin
                  WPal:=Image16Array[i];
                  if WPal>Max then Max:=WPal;
                  if WPal<Min then Min:=WPal;
                end;
              TypeTIFF:=imGray10;
              UpperValue:=1023;
              if Max>=1024 then
                begin
                  TypeTIFF:=imGray12;
                  UpperValue:=4095
                end;
              if Max>=4096 then
                begin
                  TypeTIFF:=imGray14;
                  UpperValue:=16383;
                end;
              if Max>=16384 then
                begin
                  TypeTIFF:=imGray16;
                  UpperValue:=65535;
                end;
            try
              finally
              end;
            except
            end;
          end;
        if GrayBits=8 then
          begin
            (* Vytvoreni bitmapy *)
            try
              GetMem(Image16Array,DX*DY*2);
              for k:=1 to DPC do
                begin
                  GetTIFFData(FileArray,TIFFinfo[Index].DataPoint,DP,4,k-1);
                  GetTIFFData(FileArray,TIFFinfo[Index].LengthBands,LB,4,k-1);
                  for j:=1 to LIB do
                    begin
                      jj:=(k-1)*LIB+j-1;
                      if Dy>jj then
                        for i:=0 to DX-1 do
                          Image16Array^[jj*DX+i]:=FileArray^[DP+((j-1)*DX)+i];
                    end;
                end;
              TypeTIFF:=imGray;
              UpperValue:=255;
            try
              finally
              end;
            except
            end;
          end;
      end;
    (******************************* RGB *************************)
    if TypeTIFF = imRGB then
      begin
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,RedBits,2,0);
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,GreenBits,2,1);
        GetTIFFData(FileArray,TIFFinfo[Index].Bits,BlueBits,2,2);
        GetTIFFData(FileArray,TIFFinfo[Index].Planar,Planar,2,0);
        (* Vytvoreni bitmapy *)
        DPC:=TIFFinfo[Index].DataPoint.Count;
        (* 16-mi bitovy obraz *)
        if (RedBits=16) and (GreenBits=16) and (BlueBits=16) then
          begin
            GetMem(Image16Array,DX*DY*6);
            for k:=1 to DPC do
              begin
                GetTIFFData(FileArray,TIFFinfo[Index].DataPoint,DP,4,k-1);
                GetTIFFData(FileArray,TIFFinfo[Index].LengthBands,LB,4,k-1);
                for j:=1 to LIB do
                  begin
                    jj:=(k-1)*LIB+j-1;
                    if Dy>jj then
                      begin
                        if Planar=1 then
                          begin
                            P1:=@FileArray[DP+(j-1)*DX*6];
                            P2:=@Image16Array[(jj*DX)*3];
                            Move(P1^,P2^,DX*6);
                          end;
                      end;
                  end;
              end;
            Max:=-2147483646;
            Min:=2147483646;
            for i:=0 to DX*DY-1 do
              begin
                jj:=i*3;
                for l:=0 to 2 do
                  begin
                    WPal:=Image16Array[jj+l];
                    if WPal>Max then Max:=WPal;
                    if WPal<Min then Min:=WPal;
                  end;
                Image16Array[jj+2]:=Image16Array[jj];
                Image16Array[jj]:=WPal;
              end;
            TypeTIFF:=imRGB10;
            UpperValue:=1023;
            if Max>=1024 then
              begin
                TypeTIFF:=imRGB12;
                UpperValue:=4095
              end;
            if Max>=4096 then
              begin
                TypeTIFF:=imRGB14;
                UpperValue:=16383;
              end;
            if Max>=16384 then
              begin
                TypeTIFF:=imRGB16;
                UpperValue:=65535;
              end;
          end;
        if (RedBits=8) and (GreenBits=8) and (BlueBits=8) then
          begin
            GetMem(Image16Array,DX*DY*6);
            for k:=1 to DPC do
              begin
                GetTIFFData(FileArray,TIFFinfo[Index].DataPoint,DP,4,k-1);
                GetTIFFData(FileArray,TIFFinfo[Index].LengthBands,LB,4,k-1);
                for j:=1 to LIB do
                  begin
                    jj:=(k-1)*LIB+j-1;
                    if Dy>jj then
                      begin
                        if Planar=1 then
                          begin
                            for i:=0 to DX*3-1 do
                              Image16Array^[jj*DX*3+i]:=FileArray^[DP+((j-1)*DX*3)+i];
                          end;
                      end;
                  end;
              end;
            Max:=-2147483646;
            Min:=2147483646;
            for i:=0 to DX*DY-1 do
              begin
                jj:=i*3;
                for l:=0 to 2 do
                  begin
                    WPal:=Image16Array[jj+l];
                    if WPal>Max then Max:=WPal;
                    if WPal<Min then Min:=WPal;
                  end;
                Image16Array[jj+2]:=Image16Array[jj];
                Image16Array[jj]:=WPal;
              end;
            TypeTIFF:=imRGB;
            UpperValue:=255;
          end;
      end;
 try
      finally
      end;
    (* Nastaveni meritka *)
    ImageScale:=0;
  try
    finally
      FileClose(s);
      FreeMem(FileArray,Size);
    end;
  except
  end;
end;

procedure LoadFromFilePNG(FileName: TFileName; var Width,Height,TI: Integer; var Data: Pointer);
var f: File;
    IsGray,ImageDx,ImageDy,BpP,i,j: Integer;
    Name: Pointer;
    WorkFile: TFileName;
    SL: PByteArray;
    Positj,Adri: Integer;
    BA: PArray;
    WA: PWordArray;
    ArrayGray: Array[0..15] of Byte;
    BW: Word;
begin
  GetMem(Name,Length(FileName)+1);
  StrPCopy(Name,FileName);
  if get_png_info(Name,@ImageDx,@ImageDy,@BpP,@IsGray)=1 then
    begin
      Width:=ImageDx;
      Height:=ImageDy;
      if IsGray=1 then
        begin
          if BpP=8 then
            begin
              GetMem(Data,ImageDx*ImageDy);
              load_png_gray8(Name,@Data,@ImageDx,@ImageDy,nil);
              TI:=imGray;
            end;
          if BpP=16 then
            begin
              GetMem(Data,ImageDx*ImageDy*2);
              load_png_gray16(Name,@Data,@ImageDx,@ImageDy,nil);
              TI:=imGray16;
            end;
        end
      else
        begin
          if BpP=8 then
            begin
              GetMem(Data,ImageDx*ImageDy*3);
              load_png_rgb8(Name,@Data,@ImageDx,@ImageDy,nil);
              TI:=imRGB;
            end;
          if BpP=16 then
            begin
              GetMem(Data,ImageDx*ImageDy*3*2);
              load_png_rgb16(Name,@Data,@ImageDx,@ImageDy,nil);
              TI:=imRGB16;
            end;
        end;
    end;
  FreeMem(Name,Length(FileName)+1);
end;


procedure ImageToTIFF8(BMP: TBitmap; SaveFile: AnsiString);
var i,j,k: Word;
    s: Integer;
    SL: PByteArray;
    Line: Array[0..30000] of Word;
    BLine: Array[0..30000] of Byte;
    Adr1,Adr2: Longint;
begin
  try
    s:=FileCreate(SaveFile);
    if BMP.PixelFormat=pf8bit then
      begin
        WriteTIFFHeaderGray(s,BMP.Width,BMP.Height,8,1,True);
        for j:=0 to BMP.Height-1 do
          begin
            SL:=BMP.ScanLine[j];
            FileWrite(s,SL^,BMP.Width);
          end;
      end;
    if BMP.PixelFormat=pf24bit then
      begin
        WriteTIFFHeaderRGB(s,BMP.Width,BMP.Height,8,1,True);
        for j:=0 to BMP.Height-1 do
          begin
            SL:=BMP.ScanLine[j];
            for i:=0 to BMP.Width-1 do
              for k:=0 to 2 do
                begin
                  Adr1:=i*3+k;
                  Adr2:=i*3+2-k;
                  BLine[Adr1]:=SL[Adr2]+0;
                end;
            FileWrite(s,BLine,BMP.Width*3);
          end;
      end;
    try
      finally
        FileClose(s);
      end;
    except
      on EInOutError do
        begin
//          EInOutMsg;
          Exit;
        end;
      else
        begin
//          EElseMsg;
          Exit;
        end;
    end;
end;

procedure ImageToTIFF16(P: Pointer; IW,IH: Integer; Gray: Boolean; SaveFile: AnsiString);
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.
