Delphi で Rinkaku Application その４

前回に引き続き、Turbo Delphi で Rinkaku Application をつくる、の４回目。

今回は、いままでつくったフィルタ関数をまとめて RinkakuUtils.pas をつくる。
さらに、これに 前々回の Edge3() を変形した二次微分によるエッジ検出フィルタ
Edge4() を作ってテストする。

まとめた RinkakuUtils.pas のソースを示す。

unit RinkakuUtils;

interface

uses
  Windows, SysUtils, Classes, Graphics, Controls, StdCtrls, Math;

function Contour3(var bmp: TBitmap; Stretch: Boolean = true): Boolean;
function Contour4(var bmp: TBitmap; Stretch: Boolean = true): Boolean;

function SobelInvert(var bmp: TBitmap; fGray: Boolean = true):Boolean;

function Edge3(var bmp: TBitmap; fGray: Boolean = true):Boolean;


implementation

uses
  VCLImageUtils;

function Contour3(var bmp: TBitmap; Stretch: Boolean = true): Boolean;
const
  ix: array[0..3] of integer = (1, 1, 1, 0);
  iy: array[0..3] of integer = (-1, 0, 1, 1);
var
  tmp: TBitmap;
  src: TBmpData24;
  dst: TBmpData8;
  w, h, x, y, jx, jy, i: integer;
  s, t: PRGBTriple;
  r: array[0..3] of integer;
  d3, max: double;
begin
  result := false;
  if bmp.PixelFormat <> pf24bit then exit;

  w := bmp.Width;
  h := bmp.Height;

  tmp := TBitmap.Create;
  tmp.PixelFormat := pf8bit;
  tmp.Width := w;
  tmp.Height := h;
  SetGrayPalette(tmp);

  d3 := sqrt(3.0);

  src := TBmpData24.Create(bmp);
  dst := TBmpData8.Create(tmp);

  for y := 0 to h-1 do
    for x := 0 to w-1 do
    begin
      s := src[x,y];

      for i := 0 to 3 do
      begin
        jx := x + ix[i];
        jy := y + iy[i];

        if ((jx > w -1) or (jy <0) or (jy > h-1)) then
          r[i] := 0
        else
        begin
          t := src[jx, jy];
          r[i] := (s^.rgbtRed - t^.rgbtRed) *  (s^.rgbtRed - t^.rgbtRed) +
                  (s^.rgbtGreen - t^.rgbtGreen) *  (s^.rgbtGreen - t^.rgbtGreen) +
                  (s^.rgbtBlue - t^.rgbtBlue) *  (s^.rgbtBlue - t^.rgbtBlue);
        end;
      end;

      max := 0;

      for i := 0 to 3 do if r[i] > max then max := r[i];

      dst[x,y]^ := AdjustByte(255 - Sqrt(max) / d3);
    end;

  dst.Free;
  src.Free;

  if Stretch then HistoStretch(tmp);

  bmp.Free;
  bmp := tmp;
  result := true;
end;

function Contour4(var bmp: TBitmap; Stretch: Boolean = true): Boolean;
const
  ix: array[0..7] of integer = (-1, 0, 1, -1, 1, -1 , 0, 1);
  iy: array[0..7] of integer = (-1, -1, -1, 0, 0, 1, 1, 1);
var
  tmp: TBitmap;
  src: TBmpData24;
  dst: TBmpData8;
  w, h, x, y, jx, jy, i: integer;
  s, t: PRGBTriple;
  r: array[0..7] of integer;
  d3, max: double;
begin
  result := false;
  if bmp.PixelFormat <> pf24bit then exit;

  w := bmp.Width;
  h := bmp.Height;

  tmp := TBitmap.Create;
  tmp.PixelFormat := pf8bit;
  tmp.Width := w;
  tmp.Height := h;
  SetGrayPalette(tmp);

  d3 := sqrt(3.0);

  src := TBmpData24.Create(bmp);
  dst := TBmpData8.Create(tmp);

  for y := 0 to h-1 do
    for x := 0 to w-1 do
    begin
      s := src[x,y];

      for i := 0 to 7 do
      begin
        jx := x + ix[i];
        jy := y + iy[i];

        if ((jx <0) or (jx > w -1) or (jy <0) or (jy > h-1)) then
          r[i] := 0
        else
        begin
          t := src[jx, jy];
          r[i] := (s^.rgbtRed - t^.rgbtRed) *  (s^.rgbtRed - t^.rgbtRed) +
                  (s^.rgbtGreen - t^.rgbtGreen) *  (s^.rgbtGreen - t^.rgbtGreen) +
                  (s^.rgbtBlue - t^.rgbtBlue) *  (s^.rgbtBlue - t^.rgbtBlue);
        end;
      end;

      max := 0;

      for i := 0 to 7 do if r[i] > max then max := r[i];

      dst[x,y]^ := AdjustByte(255 - Sqrt(max) / d3);
    end;

  dst.Free;
  src.Free;

  if Stretch then HistoStretch(tmp);

  bmp.Free;
  bmp := tmp;
  result := true;
end;

function SobelInvert(var bmp: TBitmap; fGray: Boolean = true):Boolean;
const
  hmask: array[-1..1] of array[-1..1] of integer = ((-1,-2,-1),
                                                    ( 0, 0, 0),
                                                    ( 1, 2, 1));
  vmask: array[-1..1] of array[-1..1] of integer = ((-1, 0, 1),
                                                    (-2, 0, 2),
                                                    (-1, 0, 1));
var
  tmp:TBitmap;
  w, h, ix, iy, x, y, xx, yy: integer;
  src, dst: TBmpData24;
  d: PRGBTriple;
  rv, gv, bv, rh, gh, bh: integer;
  d2: double;
begin
  result := false;
  if bmp.PixelFormat <> pf24bit then exit;

  w := bmp.Width;
  h := bmp.Height;

  d2 := 1.0 / Sqrt(2.0);

  tmp := BmpClone(bmp);

  src := TBmpData24.Create(tmp);
  dst := TBmpData24.Create(bmp);

  for iy := 0 to h-1 do
    for ix := 0 to w-1 do
    begin
      rv := 0; gv := 0; bv := 0; rh := 0; gh := 0; bh := 0;
      for y := iy-1 to iy+1 do
        for x := ix-1 to ix+1 do
        begin
          if (y<0) or (y>h-1) then yy := iy else yy := y;
          if (x<0) or (x>w-1) then xx := ix else xx := x;
          d := src[xx,yy];

          rv := rv + vmask[x-ix,y-iy]*d^.rgbtRed;
          gv := gv + vmask[x-ix,y-iy]*d^.rgbtGreen;
          bv := bv + vmask[x-ix,y-iy]*d^.rgbtBlue;

          rh := rh + hmask[x-ix,y-iy]*d^.rgbtRed;
          gh := gh + hmask[x-ix,y-iy]*d^.rgbtGreen;
          bh := bh + hmask[x-ix,y-iy]*d^.rgbtBlue;
        end;
      d := dst[ix,iy];

      d^.rgbtRed := 255 - AdjustByte(sqrt(rv*rv+rh*rh) * d2);
      d^.rgbtGreen := 255 - AdjustByte(sqrt(gv*gv+gh*gh) * d2);
      d^.rgbtBlue := 255 - AdjustByte(sqrt(bv*bv+bh*bh) * d2);

    end;

  dst.Free;
  src.Free;

  tmp.Free;

  if fGray then GrayScale(bmp);

  HistoStretch(bmp);

  result := true;
end;

function Edge3(var bmp: TBitmap; fGray: Boolean = true):Boolean;
const
  mask: array[-2..2] of array[-2..2] of integer =
                          ( (-1, -2, -3, -2, -1),
                            (-2, -3, -4, -3, -2),
                            (-3, -4, 60, -4, -3),
                            (-2, -3, -4, -3, -2),
                            (-1, -2, -3, -2, -1) );
var
  tmp:TBitmap;
  w, h, ix, iy, x, y, xx, yy: integer;
  src, dst: TBmpData24;
  d: PRGBTriple;
  r, g, b: integer;
begin
  result := false;
  if bmp.PixelFormat <> pf24bit then exit;
  w := bmp.Width;
  h := bmp.Height;

  tmp := BmpClone(bmp);

  src := TBmpData24.Create(tmp);
  dst := TBmpData24.Create(bmp);

  for iy := 0 to h-1 do
    for ix := 0 to w-1 do
    begin
      r := 0; g := 0; b := 0;
      for y := iy-2 to iy+2 do
        for x := ix-2 to ix+2 do
        begin
          if (y<0) or (y>h-1) then yy := iy else yy := y;
          if (x<0) or (x>w-1) then xx := ix else xx := x;
          d := src[xx,yy];

          r := r + mask[x-ix,y-iy]*d^.rgbtRed;
          g := g + mask[x-ix,y-iy]*d^.rgbtGreen;
          b := b + mask[x-ix,y-iy]*d^.rgbtBlue;

        end;
      d := dst[ix,iy];

      d^.rgbtRed := AdjustByte(r+255);
      d^.rgbtGreen := AdjustByte(g+255);
      d^.rgbtBlue := AdjustByte(b+255)
    end;

  dst.Free;
  src.Free;

  tmp.Free;

  if fGray then GrayScale(bmp);

  result := true;
end;

end.