Chip 2002 September/Chip_2002-09_cd1.bin/zkuste/delphi/navody/JBOOSTER.ZIP/Source/Rasters.pas

Pascal/Delphi Source File | 2002-06-15 | 29.8 KB | 980 lines

(*************************************************************************)
(*                                jBooster                               *)
(*                        (c) [e-mail]                    *)
(*************************************************************************)
{$J+,H+,A+,B-}
 Unit Rasters;

 Interface

 Uses
     SysUtils, Windows, Classes, Graphics;

(*************************************************************************)
(*                                edit image                             *)
(*************************************************************************)
 function RBGBalanceBmp (Source, Dest: TBitMap; Red, Blue, Green: shortint): boolean;
 function FocusBmp (Source, Dest: TBitMap; Delta: shortint; Difference: byte; Limit: boolean): boolean;
 function FlipBmp (Source, Dest: TBitMap; Horizontal, Vertical: boolean): boolean;
 function RotateBmp (Source, Dest: TBitMap; Angle: integer; Resize: boolean): boolean;

(*************************************************************************)
(*                               resize image                            *)
(*************************************************************************)
 Type
    TResizeFilter = (rfLinear, rfLanczos3);

 function QuicklyResizeBmp (Source, Dest: TBitmap; Width, Height: word): boolean;
 function FilterResizeBmp (Source, Dest: TBitmap; Width, Height: word; Filter: TResizeFilter): boolean;

(*************************************************************************)
(*                              create thumbnail                         *)
(*************************************************************************)
 Type
   { horizontal: left, center, right; vertical: top, middle, bottom }
     TAnchor = 0..2;

 function ThumbnailBmp (Source, Dest: TBitmap; ScaleX, ScaleY: Single): boolean; overload;
 function ThumbnailBmp (Bmp: TBitMap; Width, Height: word; AnchorX, AnchorY: TAnchor; Mode: boolean; const Fill: TColor = 0): boolean; overload;

(*************************************************************************)
(*                               compare image                           *)
(*************************************************************************)
 Const
     MatrixLimit = 32;
     MatrixRight = Pred (MatrixLimit);

 Type
    PMatrix = ^TMatrix;
    TMatrix = packed array [0..MatrixRight] of longword;

 function BmpMatrix (Bmp: TBitMap; var Matrix: TMatrix): boolean;
 function EquMatrix (First, Second : PMatrix; Likeness: byte): boolean;

 Implementation

(*************************************************************************)
(*                               support                                 *)
(*************************************************************************)
 Type
   { 24-bit color }
     PBGR = ^TBGR;
     TBGR = packed array [0..2] of byte;

   { color buffer }
     TBGRSum = packed array [0..2] of integer;

   { color line }
     PScanLine = ^TScanLine;
     TScanLine = packed array [0..MaxShort] of TBGR;

   { color table }
     PScanLines = ^TScanLines;
     TScanLines = packed array of PScanLine;

 Const
     MaxBGR : TBGR = (MaxByte, MaxByte, MaxByte);
     MinBGR : TBGR = (0, 0, 0);

 procedure Error;
 begin
     raise ERangeError.Create ('The parameter is incorrect');
 end; { Error }

 procedure TestSize (const Size: integer);
 begin
     if (Size <= 0) or (Size > MaxShort) then Error;
 end; { TestSize }

 procedure TestSource (Source: TBitMap);
 begin
     if Assigned (Source) then begin
        TestSize (Source.Width);
        TestSize (Source.Height);
        Source.PixelFormat := pf24Bit;
     end { if }
     else Error;
 end; { TestSource }

 function TestDest (Source, Dest: TBitMap): boolean;
 begin
     Result := (Dest <> nil) and (Dest <> Source);
 end; { TestDest }

 procedure InitBmp (Bmp: TBitMap; const Width, Height: integer);
 begin
     Bmp.PixelFormat := pf24Bit;
     Bmp.Width := Width;
     Bmp.Height := Height;
 end; { InitBmp }

 procedure BmpScanLines (Bmp: TBitMap; var Lines: TScanLines);
 var
     P    : PScanLine;
     i, j : integer;
 begin
     SetLength (Lines, Bmp.Height);
     P := Bmp.ScanLine [0];
     j := Integer (Bmp.ScanLine [Succ (0)]) - Integer (P);
     for i := 0 to Pred (Length (Lines)) do begin
         Lines [i] := P;
         Inc (Integer (P), j);
     end; { for }
 end; { BmpScanLines }

 function Target (Source, Dest: TBitMap; var Src, Dst: TScanLines): PScanLines;
 begin
   { source }
     TestSource (Source);
     BmpScanLines (Source, Src);
   { dest }
     if TestDest (Source, Dest) then begin
        InitBmp (Dest, Source.Width, Source.Height);
        BmpScanLines (Dest, Dst);
        Result := @Dst;
     end { if }
     else Result := @Src;
 end; { Target }

(*************************************************************************)
(*                             balance                                   *)
(*************************************************************************)
 function RBGBalanceBmp (Source, Dest: TBitMap; Red, Blue, Green: shortint): boolean;
 var
     Src   : TScanLines;
     Dst   : TScanLines;
     Rows  : PScanLines;
     Value : TBGRSum;
     w, h  : integer;
     x, y  : integer;
     n, k  : integer;
 begin
     Result := true;
   { nothing to do }
     if (Red = 0) and (Blue = 0) and (Green = 0) then begin
        if TestDest (Source, Dest) then Dest.Assign (Source);
        Exit;
     end; { if }
   { run }
     Try
     { test }
       Rows := Target (Source, Dest, Src, Dst);
     { init }
       Value [0] := Blue * 2;
       Value [1] := Green * 2;
       Value [2] := Red * 2;
     { size }
       w := Pred (Source.Width);
       h := Pred (Source.Height);
     { y }
       for y := 0 to h do begin
         { x }
           for x := 0 to w do begin
             { color }
               for n := 0 to 2 do begin
                 { new value }
                   k := Src [y]^[x][n] + Value [n];
                 { range }
                   if k < 0 then Rows^[y]^[x][n] := 0
                      else if k > MaxByte then Rows^[y]^[x][n] := MaxByte
                              else Rows^[y]^[x][n] := k;
               end; { for }
           end; { for }
       end; { for }
     Except
     { bugs or out of memory }
       Result := false;
     end; { try }
   { free }
     SetLength (Src, 0);
     SetLength (Dst, 0);
 end; { RBGBalanceBmp }

(*************************************************************************)
(*                                focus                                  *)
(*************************************************************************)
 function FocusBmp (Source, Dest: TBitMap; Delta: shortint; Difference: byte; Limit: boolean): boolean;
 var
     Src  : TScanLines;
     Dst  : TScanLines;
     BGR  : TBGRSum;
     Buff : boolean;
     Sign : boolean;
     a, b : integer;
     c, d : integer;
     w, h : integer;
     i, j : integer;
     x, y : integer;
     l, t : integer;
     k, n : integer;
 begin
     Result := true;
   { nothing to do }
     if (Delta = 0) or (Difference = 0) then begin
        if TestDest (Source, Dest) then Dest.Assign (Source);
        Exit;
     end; { if }
   { buffer }
     Buff := not TestDest (Source, Dest);
     if Buff then Dest := TBitMap.Create;
   { run }
     Try
     { test }
       Target (Source, Dest, Src, Dst);
     { init }
       w := Pred (Source.Width);
       h := Pred (Source.Height);
       d := Difference * 3;
       Sign := Delta < 0;
       Delta := Abs (Delta);
     { y }
       for j := 0 to h do begin
         { x }
           for i := 0 to w do begin
             { item }
               BGR [0] := Src [j]^[i][0];
               BGR [1] := Src [j]^[i][1];
               BGR [2] := Src [j]^[i][2];
               a := BGR [0] + BGR [1] + BGR [2];
             { neighbours }
               if j > 0 then t := Pred (j) else t := j;
               if i > 0 then l := Pred (i) else l := i;
               if j < h then k := Succ (j) else k := j;
               if i < w then n := Succ (i) else n := i;
             { sum }
               c := 0;
               b := 0;
               for y := t to k do for x := l to n do begin
                  if (x <> i) or (y <> j) then begin
                     Inc (b, Src [y]^[x][0] + Src [y]^[x][1] + Src [y]^[x][2]);
                     Inc (c);
                  end; { if }
               end; { for }
             { calc }
               b := a - (b div c);
               a := Abs (b);
             { test }
               if a >= d then begin
                { delta }
                  if Limit and (Delta > a) then c := a
                     else c := Delta;
                { sign }
                  if (b > 0) xor (not Sign) then c := - c;
                { update }
                  Inc (BGR [0], c);
                  Inc (BGR [1], c);
                  Inc (BGR [2], c);
               end; { if }
             { move }
               for n := 0 to 2 do begin
                   if BGR [n] > MaxByte then Dst [j]^[i][n] := MaxByte
                      else if BGR [n] < 0 then Dst [j]^[i][n] := 0
                              else Dst [j]^[i][n] := BGR [n]
               end; { for }
           end; { for }
       end; { for }
     { result }
       if Buff then Source.Canvas.Draw (0, 0, Dest);
     Except
     { bugs or out of memory }
       Result := false;
     end; { try }
   { free }
     if Buff then Dest.Free;
     SetLength (Src, 0);
     SetLength (Dst, 0);
 end; { FocusBmp }

(*************************************************************************)
(*                                 flip                                  *)
(*************************************************************************)
 function FlipBmp (Source, Dest: TBitMap; Horizontal, Vertical: boolean): boolean;
 var
     Src  : TScanLines;
     Dst  : TScanLines;
     Rows : PScanLines;
     Buff : PScanLine;
     BGR  : TBGR;
     i, j : integer;
     w, h : integer;
     n, k : integer;
     z    : integer;
 begin
     Result := true;
   { nothing to do }
     if not (Horizontal or Vertical) then begin
        if TestDest (Source, Dest) then Dest.Assign (Source);
        Exit;
     end; { if }
   { init }
     Buff := nil;
     z := 0;
   { run }
     Try
     { test }
       Rows := Target (Source, Dest, Src, Dst);
     { size }
       w := Source.Width;
       h := Source.Height;
     { horizontal }
       if Horizontal then begin
          n := Pred (w shr 1);
        { y }
          for j := 0 to Pred (h) do begin
              k := Pred (w);
            { x }
              for i := 0 to n do begin
                { exchange }
                  BGR := Src [j]^[i];
                  Rows^[j]^[i] := Src [j]^[k];
                  Rows^[j]^[k] := BGR;
                { next }
                  Dec (k)
              end; { for }
          end; { for }
       end; { if }
     { vertical }
       if Vertical then begin
        { init }
          z := w * SizeOf (TBGR);
          GetMem (Buff, z);
          k := Pred (h);
        { y }
          for j := 0 to Pred (h shr 1) do begin
            { exchange }
              Move (Rows^[j]^, Buff^, z);
              Move (Rows^[k]^, Rows^[j]^, z);
              Move (Buff^, Rows^[k]^, z);
            { next }
              Dec (k);
          end; { for }
       end; { if }
     Except
     { bugs or out of memory }
       Result := false;
     end; { try }
   { free }
     if Buff <> nil then FreeMem (Buff, z);
     SetLength (Src, 0);
     SetLength (Dst, 0);
 end; { FlipBmp }

(*************************************************************************)
(*                               rotate                                  *)
(*************************************************************************)
 function RotateBmp (Source, Dest: TBitMap; Angle: integer; Resize: boolean): boolean;
 var
     Src    : TScanLines;
     Dst    : TScanLines;
     Buff   : boolean;
     Center : TPoint;
     Midle  : TPoint;
     c, s   : Single;
     w, h   : integer;
     n, k   : integer;
     i, j   : integer;
     a, b   : integer;
     x, y   : integer;
 begin
     Result := true;
   { nothing to do }
     if Angle = 0 then begin
        if TestDest (Source, Dest) then Dest.Assign (Source);
        Exit;
     end; { if }
   { buffer }
     Buff := not TestDest (Source, Dest);
     if Buff then Dest := TBitMap.Create;
   { run }
     Try
     { test }
       TestSource (Source);
       BmpScanLines (Source, Src);
     { init }
       w := Source.Width;
       h := Source.Height;
     { angle }
       c := - (Angle * Pi / 180);
       s := Sin (c);
       c := Cos (c);
     { dest size }
       if Resize then begin
          n := Round (Abs (h * s) + Abs (w * c));
          k := Round (Abs (h * c) + Abs (w * s));
       end { if }
       else begin
          n := w;
          k := h;
       end; { else }
       InitBmp (Dest, n, k);
       BmpScanLines (Dest, Dst);
     { source center }
       Center.y := w shr 1;
       Center.x := h shr 1;
     { dest center }
       Midle.y := n shr 1;
       Midle.x := k shr 1;
     { update }
       Dec (w);
       Dec (h);
       Dec (n);
       Dec (k);
     { y }
       for j := k downto 0 do begin
           a := Succ ((j - Midle.x) shl 1);
         { x }
           for i := n downto 0 do begin
               b := Succ ((i - Midle.y) shl 1);
               x := Center.y + Pred (Round (b * c - a * s)) div 2;
               y := Center.x + Pred (Round (b * s + a * c)) div 2;
             { fill }
               if (x < 0) or (x > w) or (y < 0) or (y > h) then Dst [j]^[i] := MaxBGR
                { copy }
                  else Dst [j]^[i] := Src [y]^[x]
           end; { for }
       end; { for }
     { result }
       if Buff then Source.Assign (Dest);
     Except
     { bugs or out of memory }
       Result := false;
     end; { try }
   { free }
     if Buff then Dest.Free;
     SetLength (Src, 0);
     SetLength (Dst, 0);
 end; { RotateBmp }

(*************************************************************************)
(*                            quickly resize                             *)
(*************************************************************************)
 function QuicklyResizeBmp (Source, Dest: TBitmap; Width, Height: word): boolean;
 var
     Buff : boolean;
 begin
     Result := true;
   { nothing to do }
     if (Width = Source.Width) and (Height = Source.Height) then begin
        if TestDest (Source, Dest) then Dest.Assign (Source);
        Exit;
     end; { if }
   { buffer }
     Buff := not TestDest (Source, Dest);
     if Buff then Dest := TBitMap.Create;
   { run }
     Try
     { test }
       TestSize (Height);
       TestSize (Width);
       TestSource (Source);
     { init }
       InitBmp (Dest, Width, Height);
     { resize }
       Dest.Canvas.StretchDraw (Rect (0, 0, Width, Height), Source);
     { result }
       if Buff then Source.Assign (Dest);
     Except
     { bugs or out of memory }
       Result := false;
     end; { try }
   { free }
     if Buff then Dest.Free;
 end; { QuicklyResizeBmp }

(*************************************************************************)
(*                            filter resize                              *)
(*************************************************************************)
 function Linear (X: single): single;
 begin
     if x < 0 then x := - x;
     if x < 1 then Result := 1 - x
        else Result := 0;
 end; { Linear }

 function Lanczos3 (X: single): single;
 begin
     if X <> 0 then begin
        if X < 0 then X := - X;
        if X < 3 then begin
           X := X * Pi;
           Result := Sin (X) / X;
           X := X / 3;
           Result := Result * (Sin (X) / X);
        end { if }
        else Result := 0;
     end { if }
     else Result := 1;
 end; { Lanczos3 }

 function FilterResizeBmp (Source, Dest: TBitmap; Width, Height: word; Filter: TResizeFilter): boolean;
 type
   { filter }
     TFilter = function (X: single): single;
   { pixel }
     TPixel = packed record
       Place : integer;
       Quota : integer;
     end; { TPixel }
   { group }
     TPixelGroup = packed record
       Pixels : array of TPixel;
       Count  : integer;
     end; { TPixelGroup }
   { list }
     TGroupList = array of TPixelGroup;

 const
     Filters : array [TResizeFilter] of TFilter = (Linear, Lanczos3);
     Radius : array [TResizeFilter] of single = (1, 3);
 var
     List : TGroupList;

  procedure Calc (OldSize, NewSize : integer);
  const
      Limit = Succ (MaxByte);
  var
      Scale  : Single;
      Center : Single;
      Space  : Single;
      Quota  : integer;
      i, j   : integer;
      k, n   : integer;
      q      : Single;
      Down   : boolean;
  begin
    { scale }
      if (OldSize = 1) or (NewSize = 1) then Scale := NewSize / OldSize
         else Scale := Pred (NewSize) / Pred (OldSize);
    { decrease or increase }
      Down := Scale < 1;
    { space }
      if Down then Space := Radius [Filter] / Scale
         else Space := Radius [Filter];
    { init list }
      SetLength (List, NewSize);
    { calc }
      for i := 0 to Pred (NewSize) do begin
        { init item }
          List [i].Count := 0;
          SetLength (List [i].Pixels, Trunc (2 * Space + 1));
        { center }
          Center := i / Scale;
        { left }
          q := Center - Space;
          k := Trunc (q);
          if Frac (q) < 0 then Dec (k);
        { right }
          q := Center + Space;
          n := Trunc (q);
          if Frac (q) > 0 then Inc (n);
        { left - right }
          for j := k to n do begin
            { quota }
              q := Center - j;
              if not Down then Quota := Round (Filters [Filter] (q) * Limit)
                 else Quota := Round (Filters [Filter] (q * Scale) * Scale * Limit);
            { test }
              if Quota <> 0 then begin
              { range }
                 if j >= OldSize then n := OldSize - j + Pred (OldSize)
                    else if j < 0 then n := -j
                            else n := j;
               { update list }
                 k := List [i].Count;
                 Inc (List [i].Count);
                 List [i].Pixels [k].Quota := Quota;
                 List [i].Pixels [k].Place := n;
              end; { if }
          end; { for }
      end; { for }
  end; { Calc }

  procedure Apply (x, y: integer; var Src, Dst: TScanLines; Axis: boolean);
  var
      Buff : TBGRSum;
      S, D : PBGR;
      i, j : integer;
      k, n : integer;
  begin
      Dec (x);
      Dec (y);
    { first axis  }
      for i := 0 to x do begin
        { second axis }
          for j := 0 to y do begin
            { clear }
              Buff [0] := 0;
              Buff [1] := 0;
              Buff [2] := 0;
              n := 0;
            { dest }
              if Axis then D := @Dst [i]^[j]
                 else D := @Dst [j]^[i];
            { by list }
              With List [j] do begin
                   for k := 0 to Pred (Count) do begin
                       With Pixels [k] do begin
                          { source }
                            if Axis then S := @Src [i]^[Place]
                               else S := @Src [Place]^[i];
                          { sum with quota }
                            Inc (Buff [0], S^[0] * Quota);
                            Inc (Buff [1], S^[1] * Quota);
                            Inc (Buff [2], S^[2] * Quota);
                            Inc (n, Quota);
                       end; { With }
                   end; { for }
              end; { With }
            { result }
              if n > 0 then begin
                 for k := 0 to 2 do begin
                   { color }
                     Buff [k] := Buff [k] div n;
                   { range }
                     if Buff [k] < 0 then D^[k] := 0
                     else if Buff [k] > MaxByte then D^[k] := MaxByte
                          else D^[k] := Buff [k];
                 end; { for }
              end { if }
            { just in case }
              else D^ := MinBGR;
          end; { for }
      end; { for }
  end; { Apply }

 var
     BufRows : TScanLines;
     BmpRows : TScanLines;
     Buffer  : TBitmap;
     w, h    : integer;
 begin
     Result := true;
   { nothing to do }
     if (Width = Source.Width) and (Height = Source.Height) then begin
        if TestDest (Source, Dest) then Dest.Assign (Source);
        Exit;
     end; { if }
   { buffer }
     Buffer := TBitmap.Create;
     Try
     { test }
       TestSize (Height);
       TestSize (Width);
       TestSource (Source);
     { init }
       w := Source.Width;
       h := Source.Height;
       InitBmp (Buffer, Width, h);
     { rows }
       BmpScanLines (Source, BmpRows);
       BmpScanLines (Buffer, BufRows);
     { calc width }
       Calc (w, Width);
     { src -> buf }
       Apply (h, Width, BmpRows, BufRows, true);
     { target }
       if TestDest (Source, Dest) then begin
          InitBmp (Dest, Width, Height);
          BmpScanLines (Dest, BmpRows);
       end { if }
       else begin
            Source.Width := Width;
            Source.Height := Height;
            BmpScanLines (Source, BmpRows);
       end; { else }
     { calc height }
       Calc (h, Height);
     { buf -> target }
       Apply (Width, Height, BufRows, BmpRows, false);
     Except
     { bugs or out of memory }
       Result := false;
     end; { try }
   { free }
     for h := 0 to Pred (Length (List)) do SetLength (List[h].Pixels, 0);
     SetLength (List, 0);
     SetLength (BmpRows, 0);
     SetLength (BufRows, 0);
     Buffer.Free;
 end; { FilterResizeBmp }

(*************************************************************************)
(*                              create thumbnail                         *)
(*************************************************************************)
 function ThumbnailBmp (Source, Dest: TBitmap; ScaleX, ScaleY: Single): boolean; overload;

  procedure InitDots (var Dots: array of integer; Scale: single);
  var
      i : integer;
      q : single;
  begin
       q := 0;
       for i := 0 to Pred (Length (Dots)) do begin
           Dots [i] := Round (q);
           q := q + Scale;
       end; { for }
  end; { InitDots }

 var
     Rows : PScanLines;
     DotX : array of integer;
     DotY : array of integer;
     Summ : TBGRSum;
     Src  : TScanLines;
     Dst  : TScanLines;
     w, h : integer;
     i, j : integer;
     x, y : integer;
     n, k : integer;
     a, b : integer;
     z    : integer;
 begin
   { init }
     Result := true;
   { nothing to do }
     if (ScaleX = 1) and (ScaleY = 1) then begin
        if TestDest (Source, Dest) then Dest.Assign (Source);
        Exit;
     end; { if }
   { run }
     Try
     { test }
       if (ScaleX < 1) or (ScaleY < 1) then Error;
       TestSource (Source);
     { size }
       w := Source.Width;
       h := Source.Height;
     { new size }
       y := Round (h / ScaleY);
       x := Round (w / ScaleX);
     { init }
       BmpScanLines (Source, Src);
       if TestDest (Source, Dest) then begin
          InitBmp (Dest, x, y);
          BmpScanLines (Dest, Dst);
          Rows := @Dst;
       end { if }
       else Rows := @Src;
     { y-dots }
       SetLength (DotY, Succ (y));
       InitDots (DotY, ScaleY);
     { x-dots }
       SetLength (DotX, Succ (x));
       InitDots (DotX, ScaleX);
     { y }
       for j := 0 to Pred (y) do begin
         { y-limit }
           b := Pred (DotY [Succ (j)]);
         { x }
           for i := 0 to Pred (x) do begin
             { x-limit }
               a := Pred (DotX [Succ (i)]);
             { clear }
               Summ [0] := 0;
               Summ [1] := 0;
               Summ [2] := 0;
               z := 0;
             { y }
               for k := DotY [j] to b do begin
                 { range }
                   if k < h then begin
                    { x }
                      for n := DotX [i] to a do begin
                        { summ }
                          if (n < w) then begin
                             Inc (Summ [0], Src [k]^[n] [0]);
                             Inc (Summ [1], Src [k]^[n] [1]);
                             Inc (Summ [2], Src [k]^[n] [2]);
                             Inc (z);
                          end; { if }
                      end; { for }
                   end; { if }
               end; { for }
             { average }
               Rows^[j]^[i] [0] := Summ [0] div z;
               Rows^[j]^[i] [1] := Summ [1] div z;
               Rows^[j]^[i] [2] := Summ [2] div z;
           end; { for }
       end; { for }
     { set size }
       if Rows = @Src then begin
          Source.Height := y;
          Source.Width := x;
       end; { if }
     Except
     { bugs or out of memory }
       Result := false;
     end; { try }
   { free }
     SetLength (DotY, 0);
     SetLength (DotX, 0);
     SetLength (Src, 0);
     SetLength (Dst, 0);
 end; { ThumbnailBmp }

 function ThumbnailBmp (Bmp: TBitMap; Width, Height: word; AnchorX, AnchorY: TAnchor; Mode: boolean; const Fill: TColor = 0): boolean;

  function Offset (const Size, Limit: integer; const Anchor: TAnchor): integer;
  begin
      if Anchor > 0 then begin
         Result := Abs (Size - Limit);
         if Anchor = 1 then Result := Result shr 1;
      end { if }
      else Result := 0
  end; { Offset }

 var
     Buffer : TBitMap;
     Src    : TRect;
     Dst    : TRect;
     Scale  : single;
     w, h   : integer;
     t, l   : integer;
     x, y   : single;
 begin
     Result := true;
   { nothing to do }
     if (Width = Bmp.Width) and (Height = Bmp.Height) then Exit;
   { test }
     Try
       TestSize (Height);
       TestSize (Width);
     Except
       Result := false;
       Exit;
     end; { try }
   { scale }
     x := Bmp.Width / Width;
     y := Bmp.Height / Height;
     if Mode xor (x > y) then Scale := y
        else Scale := x;
   { buffer }
     Buffer := TBitmap.Create;
   { resize }
     if ThumbnailBmp (Bmp, Buffer, Scale, Scale) then begin
      { size }
        w := Buffer.Width;
        h := Buffer.Height;
      { offset }
        t := Offset (Height, h, AnchorY);
        l := Offset (Width, w, AnchorX);
      { move }
        Dst := Rect (0, 0, Width, Height);
        With Bmp.Canvas do begin
           { fill }
             if Mode then begin
                Brush.Color := Fill;
                FillRect (Dst);
              { draw }
                Draw (l, t, Buffer);
             end { if }
           { cut }
             else begin
                  Src := Rect (l, t, Width + l, Height + t);
                  CopyRect (Dst, Buffer.Canvas, Src);
             end; { else }
        end; { With }
      { size }
        Bmp.Height := Height;
        Bmp.Width := Width;
     end { if }
     else Result := false;
   { free }
     Buffer.Free;
 end; { ThumbnailBmp }

(*************************************************************************)
(*                               compare image                           *)
(*************************************************************************)
 function BmpMatrix (Bmp: TBitMap; var Matrix: TMatrix): boolean;
 var
     Buff : TBitMap;
     Rows : TScanLines;
     i, j : integer;
     a, b : integer;
 begin
   { init }
     Buff := TBitMap.Create;
     a := Bmp.Width;
     b := Bmp.Height;
   { decrease }
     if ThumbnailBmp (Bmp, Buff,  a / MatrixLimit,  b / MatrixLimit) then begin
      { ok }
        Result := true;
      { init }
        FillChar (Matrix, SizeOf (Matrix), 0);
        BmpScanLines (Buff, Rows);
      { y }
        for j := 0 to MatrixRight do begin
          { prev }
            a := 0;
            Inc (a, Rows [j]^[MatrixRight] [0]);
            Inc (a, Rows [j]^[MatrixRight] [1]);
            Inc (a, Rows [j]^[MatrixRight] [2]);
          { x }
            for i := 0 to MatrixRight do begin
              { curr }
                b := Rows [j]^[i][0] + Rows [j]^[i][1] + Rows [j]^[i][2];
              { difference }
                Dec (a, b);
              { levels }
                if a < 0 then Matrix [j] := Matrix [j] or (1 shl i);
              { next }
                a := b;
            end; { for }
        end; { for }
     end { if }
     else Result := false;
   { free }
     SetLength (Rows, 0);
     Buff.Free;
 end; { BmpMatrix }

 function EquMatrix (First, Second : PMatrix; Likeness: byte): boolean;

   function TestLine (const F, S: longword): boolean;
   var
       k, n : longword;
   begin
     { init }
       n := MatrixLimit;
     { compare }
       k := F xor S;
     { test }
       While (k <> 0) and (n >= Likeness) do begin
         { not equ }
           if Odd (k) then Dec (n);
         { next }
           k := k shr 1;
       end; { for }
       Result := (n >= Likeness);
   end; { TestLine }

   function TestMatrix (var F, S: TMatrix): boolean;
   var
       j, n : integer;
   begin
       n := MatrixLimit;
       j := 0;
       While (j < MatrixLimit) and (n >= Likeness) do begin
         { test }
           if not TestLine (F [j], S [j]) then Dec (n);
         { next }
           Inc (j);
       end; { While }
       Result := (n >= Likeness);
   end; { TestMatrix }

 begin
   { likeness }
     Likeness := (MatrixLimit * Likeness) div 100;
   { compare }
     Result := TestMatrix (First^, Second^);
 end; { EquMatrix }

 End.