unit Display;

interface

uses IOGraphics, extctrls, SysUtils, Dialogs;

var GammaCurve    : array[0..65535] of byte;
    GammaCurve16  : array[0..65535] of word;

procedure SetGammaCurve(Info : TImgRec; a, b : word; Gamma : integer);
procedure SetGammaCurve16(Info : TImgRec; a, b : word; Gamma : integer);
procedure DisplayBwImage(ImageDisplay : TImage; Info : TImgRec; var Img : Pointer; Stretch : integer; RepaintImg : boolean);

implementation

uses Graphics;

function sRGB_F(a, b, PixVal : word) : byte;
var x, y : single;
begin
  x:=(PixVal-a)/(b-a);
  if x<1E-9 then
    begin
      sRGB_F:=0;
      Exit;
    end;
  if x>1 then
    begin
      sRGB_F:=255;
      Exit;
    end;
  if x<=0.0031308
    then sRGB_F:=round(255*12.92*x)
    else sRGB_F:=round(255*(1.055 * exp((1/2.4)*ln(x)) - 0.055));
end;

function LinearF(a, b, PixVal : word) : byte;
var x, y : single;
begin
  x:=(PixVal-a)/(b-a);
  if x<1E-9 then
    begin
      LinearF:=0;
      Exit;
    end;
  if x>1 then
    begin
      LinearF:=255;
      Exit;
    end;
  LinearF:=round(255*x);
end;

function GammaF(a, b, PixVal : word; Gamma : single) : byte;
var x, y : single;
begin
  x:=(PixVal-a)/(b-a);
  if x<1E-9 then
    begin
      GammaF:=0;
      Exit;
    end;
  if x>1 then
    begin
      GammaF:=255;
      Exit;
    end;
  GammaF:=round(255*exp((1/Gamma)*ln(x)));
end;

procedure SetGammaCurve(Info : TImgRec; a, b : word; Gamma : integer);
var i : word;
    g : single;
begin
    if b<=a then
    begin
      a:=0;
      b:=65535;
    end;
  case Gamma of
    -1 : for i:=0 to 65535 do GammaCurve[i]:=sRGB_F(a,b,i);
    10 : for i:=0 to 65535 do GammaCurve[i]:=LinearF(a,b,i);
  else
    g:=Gamma/10;
    for i:=0 to 65535 do GammaCurve[i]:=GammaF(a,b,i,g);
  end{case}
end;


function sRGB_F16(a, b, PixVal : word) : word;
var x, y : single;
begin
  x:=(PixVal-a)/(b-a);
  if x<1E-9 then
    begin
      sRGB_F16:=0;
      Exit;
    end;
  if x>1 then
    begin
      sRGB_F16:=65535;
      Exit;
    end;
  if x<=0.0031308
    then sRGB_F16:=round(65535*12.92*x)
    else sRGB_F16:=round(65535*(1.055 * exp((1/2.4)*ln(x)) - 0.055));
end;

function LinearF16(a, b, PixVal : word) : word;
var x, y : single;
begin
  x:=(PixVal-a)/(b-a);
  if x<1E-9 then
    begin
      LinearF16:=0;
      Exit;
    end;
  if x>1 then
    begin
      LinearF16:=65535;
      Exit;
    end;
  LinearF16:=round(65535*x);
end;

function GammaF16(a, b, PixVal : word; Gamma : single) : word;
var x, y : single;
begin
  x:=(PixVal-a)/(b-a);
  if x<1E-9 then
    begin
      GammaF16:=0;
      Exit;
    end;
  if x>1 then
    begin
      GammaF16:=65535;
      Exit;
    end;
  GammaF16:=round(65535*exp((1/Gamma)*ln(x)));
end;

procedure SetGammaCurve16(Info : TImgRec; a, b : word; Gamma : integer);
var i : word;
    g : single;
begin
  if a<b then
    case Gamma of
      -1 : for i:=0 to 65535 do GammaCurve16[i]:=sRGB_F16(a,b,i);
      10 : for i:=0 to 65535 do GammaCurve16[i]:=LinearF16(a,b,i);
    else
      g:=Gamma/10;
      for i:=0 to 65535 do GammaCurve16[i]:=GammaF16(a,b,i,g);
    end{case} else
    for i:=0 to 65535 do GammaCurve16[i]:=0;
end;


procedure DisplayBwImage(ImageDisplay : TImage; Info : TImgRec; var Img : Pointer; Stretch : integer; RepaintImg : boolean);
var P               : PByteArr;
    ImgP            : PWordArr;
    i, j, w         : integer;
    Pix             : word;
    b               : byte;
    IWidth, IHeight : integer;

procedure Average(x, y : integer);
var i, j, i1, j1, i2, j2, n : integer;
     Sum                    : integer;
begin
  i1:=Stretch*x;
  j1:=Stretch*y;
  i2:=Stretch*x + Stretch-1;
  j2:=Stretch*y + Stretch-1;
  Sum:=0;
  for i:=i1 to i2 do
    for j:=j1 to j2 do
      begin
        n:=i+j*Info.ImgWidth;
        Sum:=Sum+ImgP^[n];
      end;
  Pix:=round(Sum/sqr(Stretch));
end;

begin
  if not Info.OK then Exit;
  if (Info.Channels<>1) or (UpperCase(Info.PixelType)<>'WORD') then
    begin
      ShowMessage('Sorry, procedure DisplayBwImage displays only 16 bit/pixel (data type word), BW images.');
      Exit;
    end;
  ImgP:=Img;
  IWidth:= Info.ImgWidth  div Stretch;
  IHeight:=Info.ImgHeight div Stretch;
  ImageDisplay.Picture.Bitmap.PixelFormat:=pf24bit;
  ImageDisplay.Picture.Bitmap.Width:=IWidth;
  ImageDisplay.Picture.Bitmap.Height:=IHeight;
  ImageDisplay.Width:=IWidth;
  ImageDisplay.Height:=IHeight;
  w:=Info.ImgWidth;
            {bez zmenseni}
            if Stretch=1 then for j:=0 to Info.ImgHeight-1 do
              begin
                P:=ImageDisplay.Picture.Bitmap.ScanLine[j];
                for i:=0 to Info.ImgWidth-1 do
                  begin
                    b:=GammaCurve[ImgP^[i+j*w]];
                    P^[3*i  ]:=b;
                    P^[3*i+1]:=b;
                    P^[3*i+2]:=b;
                  end;
              end;
            {se zmensenim}
            if (Stretch>1) then for j:=0 to IHeight-1 do
              begin
                P:=ImageDisplay.Picture.Bitmap.ScanLine[j];
                for i:=0 to IWidth-1 do
                  begin
                    Average(i,j);
                    b:=GammaCurve[Pix];
                    P^[3*i  ]:=b;
                    P^[3*i+1]:=b;
                    P^[3*i+2]:=b;
                  end;
              end;
  if RepaintImg then ImageDisplay.Repaint;

end;



end.
