home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 September / Chip_2002-09_cd1.bin / zkuste / delphi / navody / JBOOSTER.ZIP / Source / Rasters.pas < prev    next >
Pascal/Delphi Source File  |  2002-06-15  |  30KB  |  980 lines
  1. (*************************************************************************)
  2. (*                                jBooster                               *)
  3. (*                        (c) pulsar@mail.primorye.ru                    *)
  4. (*************************************************************************)
  5. {$J+,H+,A+,B-}
  6.  Unit Rasters;
  7.  
  8.  Interface
  9.  
  10.  Uses
  11.      SysUtils, Windows, Classes, Graphics;
  12.  
  13. (*************************************************************************)
  14. (*                                edit image                             *)
  15. (*************************************************************************)
  16.  function RBGBalanceBmp (Source, Dest: TBitMap; Red, Blue, Green: shortint): boolean;
  17.  function FocusBmp (Source, Dest: TBitMap; Delta: shortint; Difference: byte; Limit: boolean): boolean;
  18.  function FlipBmp (Source, Dest: TBitMap; Horizontal, Vertical: boolean): boolean;
  19.  function RotateBmp (Source, Dest: TBitMap; Angle: integer; Resize: boolean): boolean;
  20.  
  21. (*************************************************************************)
  22. (*                               resize image                            *)
  23. (*************************************************************************)
  24.  Type
  25.     TResizeFilter = (rfLinear, rfLanczos3);
  26.  
  27.  function QuicklyResizeBmp (Source, Dest: TBitmap; Width, Height: word): boolean;
  28.  function FilterResizeBmp (Source, Dest: TBitmap; Width, Height: word; Filter: TResizeFilter): boolean;
  29.  
  30. (*************************************************************************)
  31. (*                              create thumbnail                         *)
  32. (*************************************************************************)
  33.  Type
  34.    { horizontal: left, center, right; vertical: top, middle, bottom }
  35.      TAnchor = 0..2;
  36.  
  37.  function ThumbnailBmp (Source, Dest: TBitmap; ScaleX, ScaleY: Single): boolean; overload;
  38.  function ThumbnailBmp (Bmp: TBitMap; Width, Height: word; AnchorX, AnchorY: TAnchor; Mode: boolean; const Fill: TColor = 0): boolean; overload;
  39.  
  40. (*************************************************************************)
  41. (*                               compare image                           *)
  42. (*************************************************************************)
  43.  Const
  44.      MatrixLimit = 32;
  45.      MatrixRight = Pred (MatrixLimit);
  46.  
  47.  Type
  48.     PMatrix = ^TMatrix;
  49.     TMatrix = packed array [0..MatrixRight] of longword;
  50.  
  51.  function BmpMatrix (Bmp: TBitMap; var Matrix: TMatrix): boolean;
  52.  function EquMatrix (First, Second : PMatrix; Likeness: byte): boolean;
  53.  
  54.  Implementation
  55.  
  56. (*************************************************************************)
  57. (*                               support                                 *)
  58. (*************************************************************************)
  59.  Type
  60.    { 24-bit color }
  61.      PBGR = ^TBGR;
  62.      TBGR = packed array [0..2] of byte;
  63.  
  64.    { color buffer }
  65.      TBGRSum = packed array [0..2] of integer;
  66.  
  67.    { color line }
  68.      PScanLine = ^TScanLine;
  69.      TScanLine = packed array [0..MaxShort] of TBGR;
  70.  
  71.    { color table }
  72.      PScanLines = ^TScanLines;
  73.      TScanLines = packed array of PScanLine;
  74.  
  75.  Const
  76.      MaxBGR : TBGR = (MaxByte, MaxByte, MaxByte);
  77.      MinBGR : TBGR = (0, 0, 0);
  78.  
  79.  procedure Error;
  80.  begin
  81.      raise ERangeError.Create ('The parameter is incorrect');
  82.  end; { Error }
  83.  
  84.  procedure TestSize (const Size: integer);
  85.  begin
  86.      if (Size <= 0) or (Size > MaxShort) then Error;
  87.  end; { TestSize }
  88.  
  89.  procedure TestSource (Source: TBitMap);
  90.  begin
  91.      if Assigned (Source) then begin
  92.         TestSize (Source.Width);
  93.         TestSize (Source.Height);
  94.         Source.PixelFormat := pf24Bit;
  95.      end { if }
  96.      else Error;
  97.  end; { TestSource }
  98.  
  99.  function TestDest (Source, Dest: TBitMap): boolean;
  100.  begin
  101.      Result := (Dest <> nil) and (Dest <> Source);
  102.  end; { TestDest }
  103.  
  104.  procedure InitBmp (Bmp: TBitMap; const Width, Height: integer);
  105.  begin
  106.      Bmp.PixelFormat := pf24Bit;
  107.      Bmp.Width := Width;
  108.      Bmp.Height := Height;
  109.  end; { InitBmp }
  110.  
  111.  procedure BmpScanLines (Bmp: TBitMap; var Lines: TScanLines);
  112.  var
  113.      P    : PScanLine;
  114.      i, j : integer;
  115.  begin
  116.      SetLength (Lines, Bmp.Height);
  117.      P := Bmp.ScanLine [0];
  118.      j := Integer (Bmp.ScanLine [Succ (0)]) - Integer (P);
  119.      for i := 0 to Pred (Length (Lines)) do begin
  120.          Lines [i] := P;
  121.          Inc (Integer (P), j);
  122.      end; { for }
  123.  end; { BmpScanLines }
  124.  
  125.  function Target (Source, Dest: TBitMap; var Src, Dst: TScanLines): PScanLines;
  126.  begin
  127.    { source }
  128.      TestSource (Source);
  129.      BmpScanLines (Source, Src);
  130.    { dest }
  131.      if TestDest (Source, Dest) then begin
  132.         InitBmp (Dest, Source.Width, Source.Height);
  133.         BmpScanLines (Dest, Dst);
  134.         Result := @Dst;
  135.      end { if }
  136.      else Result := @Src;
  137.  end; { Target }
  138.  
  139. (*************************************************************************)
  140. (*                             balance                                   *)
  141. (*************************************************************************)
  142.  function RBGBalanceBmp (Source, Dest: TBitMap; Red, Blue, Green: shortint): boolean;
  143.  var
  144.      Src   : TScanLines;
  145.      Dst   : TScanLines;
  146.      Rows  : PScanLines;
  147.      Value : TBGRSum;
  148.      w, h  : integer;
  149.      x, y  : integer;
  150.      n, k  : integer;
  151.  begin
  152.      Result := true;
  153.    { nothing to do }
  154.      if (Red = 0) and (Blue = 0) and (Green = 0) then begin
  155.         if TestDest (Source, Dest) then Dest.Assign (Source);
  156.         Exit;
  157.      end; { if }
  158.    { run }
  159.      Try
  160.      { test }
  161.        Rows := Target (Source, Dest, Src, Dst);
  162.      { init }
  163.        Value [0] := Blue * 2;
  164.        Value [1] := Green * 2;
  165.        Value [2] := Red * 2;
  166.      { size }
  167.        w := Pred (Source.Width);
  168.        h := Pred (Source.Height);
  169.      { y }
  170.        for y := 0 to h do begin
  171.          { x }
  172.            for x := 0 to w do begin
  173.              { color }
  174.                for n := 0 to 2 do begin
  175.                  { new value }
  176.                    k := Src [y]^[x][n] + Value [n];
  177.                  { range }
  178.                    if k < 0 then Rows^[y]^[x][n] := 0
  179.                       else if k > MaxByte then Rows^[y]^[x][n] := MaxByte
  180.                               else Rows^[y]^[x][n] := k;
  181.                end; { for }
  182.            end; { for }
  183.        end; { for }
  184.      Except
  185.      { bugs or out of memory }
  186.        Result := false;
  187.      end; { try }
  188.    { free }
  189.      SetLength (Src, 0);
  190.      SetLength (Dst, 0);
  191.  end; { RBGBalanceBmp }
  192.  
  193. (*************************************************************************)
  194. (*                                focus                                  *)
  195. (*************************************************************************)
  196.  function FocusBmp (Source, Dest: TBitMap; Delta: shortint; Difference: byte; Limit: boolean): boolean;
  197.  var
  198.      Src  : TScanLines;
  199.      Dst  : TScanLines;
  200.      BGR  : TBGRSum;
  201.      Buff : boolean;
  202.      Sign : boolean;
  203.      a, b : integer;
  204.      c, d : integer;
  205.      w, h : integer;
  206.      i, j : integer;
  207.      x, y : integer;
  208.      l, t : integer;
  209.      k, n : integer;
  210.  begin
  211.      Result := true;
  212.    { nothing to do }
  213.      if (Delta = 0) or (Difference = 0) then begin
  214.         if TestDest (Source, Dest) then Dest.Assign (Source);
  215.         Exit;
  216.      end; { if }
  217.    { buffer }
  218.      Buff := not TestDest (Source, Dest);
  219.      if Buff then Dest := TBitMap.Create;
  220.    { run }
  221.      Try
  222.      { test }
  223.        Target (Source, Dest, Src, Dst);
  224.      { init }
  225.        w := Pred (Source.Width);
  226.        h := Pred (Source.Height);
  227.        d := Difference * 3;
  228.        Sign := Delta < 0;
  229.        Delta := Abs (Delta);
  230.      { y }
  231.        for j := 0 to h do begin
  232.          { x }
  233.            for i := 0 to w do begin
  234.              { item }
  235.                BGR [0] := Src [j]^[i][0];
  236.                BGR [1] := Src [j]^[i][1];
  237.                BGR [2] := Src [j]^[i][2];
  238.                a := BGR [0] + BGR [1] + BGR [2];
  239.              { neighbours }
  240.                if j > 0 then t := Pred (j) else t := j;
  241.                if i > 0 then l := Pred (i) else l := i;
  242.                if j < h then k := Succ (j) else k := j;
  243.                if i < w then n := Succ (i) else n := i;
  244.              { sum }
  245.                c := 0;
  246.                b := 0;
  247.                for y := t to k do for x := l to n do begin
  248.                   if (x <> i) or (y <> j) then begin
  249.                      Inc (b, Src [y]^[x][0] + Src [y]^[x][1] + Src [y]^[x][2]);
  250.                      Inc (c);
  251.                   end; { if }
  252.                end; { for }
  253.              { calc }
  254.                b := a - (b div c);
  255.                a := Abs (b);
  256.              { test }
  257.                if a >= d then begin
  258.                 { delta }
  259.                   if Limit and (Delta > a) then c := a
  260.                      else c := Delta;
  261.                 { sign }
  262.                   if (b > 0) xor (not Sign) then c := - c;
  263.                 { update }
  264.                   Inc (BGR [0], c);
  265.                   Inc (BGR [1], c);
  266.                   Inc (BGR [2], c);
  267.                end; { if }
  268.              { move }
  269.                for n := 0 to 2 do begin
  270.                    if BGR [n] > MaxByte then Dst [j]^[i][n] := MaxByte
  271.                       else if BGR [n] < 0 then Dst [j]^[i][n] := 0
  272.                               else Dst [j]^[i][n] := BGR [n]
  273.                end; { for }
  274.            end; { for }
  275.        end; { for }
  276.      { result }
  277.        if Buff then Source.Canvas.Draw (0, 0, Dest);
  278.      Except
  279.      { bugs or out of memory }
  280.        Result := false;
  281.      end; { try }
  282.    { free }
  283.      if Buff then Dest.Free;
  284.      SetLength (Src, 0);
  285.      SetLength (Dst, 0);
  286.  end; { FocusBmp }
  287.  
  288. (*************************************************************************)
  289. (*                                 flip                                  *)
  290. (*************************************************************************)
  291.  function FlipBmp (Source, Dest: TBitMap; Horizontal, Vertical: boolean): boolean;
  292.  var
  293.      Src  : TScanLines;
  294.      Dst  : TScanLines;
  295.      Rows : PScanLines;
  296.      Buff : PScanLine;
  297.      BGR  : TBGR;
  298.      i, j : integer;
  299.      w, h : integer;
  300.      n, k : integer;
  301.      z    : integer;
  302.  begin
  303.      Result := true;
  304.    { nothing to do }
  305.      if not (Horizontal or Vertical) then begin
  306.         if TestDest (Source, Dest) then Dest.Assign (Source);
  307.         Exit;
  308.      end; { if }
  309.    { init }
  310.      Buff := nil;
  311.      z := 0;
  312.    { run }
  313.      Try
  314.      { test }
  315.        Rows := Target (Source, Dest, Src, Dst);
  316.      { size }
  317.        w := Source.Width;
  318.        h := Source.Height;
  319.      { horizontal }
  320.        if Horizontal then begin
  321.           n := Pred (w shr 1);
  322.         { y }
  323.           for j := 0 to Pred (h) do begin
  324.               k := Pred (w);
  325.             { x }
  326.               for i := 0 to n do begin
  327.                 { exchange }
  328.                   BGR := Src [j]^[i];
  329.                   Rows^[j]^[i] := Src [j]^[k];
  330.                   Rows^[j]^[k] := BGR;
  331.                 { next }
  332.                   Dec (k)
  333.               end; { for }
  334.           end; { for }
  335.        end; { if }
  336.      { vertical }
  337.        if Vertical then begin
  338.         { init }
  339.           z := w * SizeOf (TBGR);
  340.           GetMem (Buff, z);
  341.           k := Pred (h);
  342.         { y }
  343.           for j := 0 to Pred (h shr 1) do begin
  344.             { exchange }
  345.               Move (Rows^[j]^, Buff^, z);
  346.               Move (Rows^[k]^, Rows^[j]^, z);
  347.               Move (Buff^, Rows^[k]^, z);
  348.             { next }
  349.               Dec (k);
  350.           end; { for }
  351.        end; { if }
  352.      Except
  353.      { bugs or out of memory }
  354.        Result := false;
  355.      end; { try }
  356.    { free }
  357.      if Buff <> nil then FreeMem (Buff, z);
  358.      SetLength (Src, 0);
  359.      SetLength (Dst, 0);
  360.  end; { FlipBmp }
  361.  
  362. (*************************************************************************)
  363. (*                               rotate                                  *)
  364. (*************************************************************************)
  365.  function RotateBmp (Source, Dest: TBitMap; Angle: integer; Resize: boolean): boolean;
  366.  var
  367.      Src    : TScanLines;
  368.      Dst    : TScanLines;
  369.      Buff   : boolean;
  370.      Center : TPoint;
  371.      Midle  : TPoint;
  372.      c, s   : Single;
  373.      w, h   : integer;
  374.      n, k   : integer;
  375.      i, j   : integer;
  376.      a, b   : integer;
  377.      x, y   : integer;
  378.  begin
  379.      Result := true;
  380.    { nothing to do }
  381.      if Angle = 0 then begin
  382.         if TestDest (Source, Dest) then Dest.Assign (Source);
  383.         Exit;
  384.      end; { if }
  385.    { buffer }
  386.      Buff := not TestDest (Source, Dest);
  387.      if Buff then Dest := TBitMap.Create;
  388.    { run }
  389.      Try
  390.      { test }
  391.        TestSource (Source);
  392.        BmpScanLines (Source, Src);
  393.      { init }
  394.        w := Source.Width;
  395.        h := Source.Height;
  396.      { angle }
  397.        c := - (Angle * Pi / 180);
  398.        s := Sin (c);
  399.        c := Cos (c);
  400.      { dest size }
  401.        if Resize then begin
  402.           n := Round (Abs (h * s) + Abs (w * c));
  403.           k := Round (Abs (h * c) + Abs (w * s));
  404.        end { if }
  405.        else begin
  406.           n := w;
  407.           k := h;
  408.        end; { else }
  409.        InitBmp (Dest, n, k);
  410.        BmpScanLines (Dest, Dst);
  411.      { source center }
  412.        Center.y := w shr 1;
  413.        Center.x := h shr 1;
  414.      { dest center }
  415.        Midle.y := n shr 1;
  416.        Midle.x := k shr 1;
  417.      { update }
  418.        Dec (w);
  419.        Dec (h);
  420.        Dec (n);
  421.        Dec (k);
  422.      { y }
  423.        for j := k downto 0 do begin
  424.            a := Succ ((j - Midle.x) shl 1);
  425.          { x }
  426.            for i := n downto 0 do begin
  427.                b := Succ ((i - Midle.y) shl 1);
  428.                x := Center.y + Pred (Round (b * c - a * s)) div 2;
  429.                y := Center.x + Pred (Round (b * s + a * c)) div 2;
  430.              { fill }
  431.                if (x < 0) or (x > w) or (y < 0) or (y > h) then Dst [j]^[i] := MaxBGR
  432.                 { copy }
  433.                   else Dst [j]^[i] := Src [y]^[x]
  434.            end; { for }
  435.        end; { for }
  436.      { result }
  437.        if Buff then Source.Assign (Dest);
  438.      Except
  439.      { bugs or out of memory }
  440.        Result := false;
  441.      end; { try }
  442.    { free }
  443.      if Buff then Dest.Free;
  444.      SetLength (Src, 0);
  445.      SetLength (Dst, 0);
  446.  end; { RotateBmp }
  447.  
  448. (*************************************************************************)
  449. (*                            quickly resize                             *)
  450. (*************************************************************************)
  451.  function QuicklyResizeBmp (Source, Dest: TBitmap; Width, Height: word): boolean;
  452.  var
  453.      Buff : boolean;
  454.  begin
  455.      Result := true;
  456.    { nothing to do }
  457.      if (Width = Source.Width) and (Height = Source.Height) then begin
  458.         if TestDest (Source, Dest) then Dest.Assign (Source);
  459.         Exit;
  460.      end; { if }
  461.    { buffer }
  462.      Buff := not TestDest (Source, Dest);
  463.      if Buff then Dest := TBitMap.Create;
  464.    { run }
  465.      Try
  466.      { test }
  467.        TestSize (Height);
  468.        TestSize (Width);
  469.        TestSource (Source);
  470.      { init }
  471.        InitBmp (Dest, Width, Height);
  472.      { resize }
  473.        Dest.Canvas.StretchDraw (Rect (0, 0, Width, Height), Source);
  474.      { result }
  475.        if Buff then Source.Assign (Dest);
  476.      Except
  477.      { bugs or out of memory }
  478.        Result := false;
  479.      end; { try }
  480.    { free }
  481.      if Buff then Dest.Free;
  482.  end; { QuicklyResizeBmp }
  483.  
  484. (*************************************************************************)
  485. (*                            filter resize                              *)
  486. (*************************************************************************)
  487.  function Linear (X: single): single;
  488.  begin
  489.      if x < 0 then x := - x;
  490.      if x < 1 then Result := 1 - x
  491.         else Result := 0;
  492.  end; { Linear }
  493.  
  494.  function Lanczos3 (X: single): single;
  495.  begin
  496.      if X <> 0 then begin
  497.         if X < 0 then X := - X;
  498.         if X < 3 then begin
  499.            X := X * Pi;
  500.            Result := Sin (X) / X;
  501.            X := X / 3;
  502.            Result := Result * (Sin (X) / X);
  503.         end { if }
  504.         else Result := 0;
  505.      end { if }
  506.      else Result := 1;
  507.  end; { Lanczos3 }
  508.  
  509.  function FilterResizeBmp (Source, Dest: TBitmap; Width, Height: word; Filter: TResizeFilter): boolean;
  510.  type
  511.    { filter }
  512.      TFilter = function (X: single): single;
  513.    { pixel }
  514.      TPixel = packed record
  515.        Place : integer;
  516.        Quota : integer;
  517.      end; { TPixel }
  518.    { group }
  519.      TPixelGroup = packed record
  520.        Pixels : array of TPixel;
  521.        Count  : integer;
  522.      end; { TPixelGroup }
  523.    { list }
  524.      TGroupList = array of TPixelGroup;
  525.  
  526.  const
  527.      Filters : array [TResizeFilter] of TFilter = (Linear, Lanczos3);
  528.      Radius : array [TResizeFilter] of single = (1, 3);
  529.  var
  530.      List : TGroupList;
  531.  
  532.   procedure Calc (OldSize, NewSize : integer);
  533.   const
  534.       Limit = Succ (MaxByte);
  535.   var
  536.       Scale  : Single;
  537.       Center : Single;
  538.       Space  : Single;
  539.       Quota  : integer;
  540.       i, j   : integer;
  541.       k, n   : integer;
  542.       q      : Single;
  543.       Down   : boolean;
  544.   begin
  545.     { scale }
  546.       if (OldSize = 1) or (NewSize = 1) then Scale := NewSize / OldSize
  547.          else Scale := Pred (NewSize) / Pred (OldSize);
  548.     { decrease or increase }
  549.       Down := Scale < 1;
  550.     { space }
  551.       if Down then Space := Radius [Filter] / Scale
  552.          else Space := Radius [Filter];
  553.     { init list }
  554.       SetLength (List, NewSize);
  555.     { calc }
  556.       for i := 0 to Pred (NewSize) do begin
  557.         { init item }
  558.           List [i].Count := 0;
  559.           SetLength (List [i].Pixels, Trunc (2 * Space + 1));
  560.         { center }
  561.           Center := i / Scale;
  562.         { left }
  563.           q := Center - Space;
  564.           k := Trunc (q);
  565.           if Frac (q) < 0 then Dec (k);
  566.         { right }
  567.           q := Center + Space;
  568.           n := Trunc (q);
  569.           if Frac (q) > 0 then Inc (n);
  570.         { left - right }
  571.           for j := k to n do begin
  572.             { quota }
  573.               q := Center - j;
  574.               if not Down then Quota := Round (Filters [Filter] (q) * Limit)
  575.                  else Quota := Round (Filters [Filter] (q * Scale) * Scale * Limit);
  576.             { test }
  577.               if Quota <> 0 then begin
  578.               { range }
  579.                  if j >= OldSize then n := OldSize - j + Pred (OldSize)
  580.                     else if j < 0 then n := -j
  581.                             else n := j;
  582.                { update list }
  583.                  k := List [i].Count;
  584.                  Inc (List [i].Count);
  585.                  List [i].Pixels [k].Quota := Quota;
  586.                  List [i].Pixels [k].Place := n;
  587.               end; { if }
  588.           end; { for }
  589.       end; { for }
  590.   end; { Calc }
  591.  
  592.   procedure Apply (x, y: integer; var Src, Dst: TScanLines; Axis: boolean);
  593.   var
  594.       Buff : TBGRSum;
  595.       S, D : PBGR;
  596.       i, j : integer;
  597.       k, n : integer;
  598.   begin
  599.       Dec (x);
  600.       Dec (y);
  601.     { first axis  }
  602.       for i := 0 to x do begin
  603.         { second axis }
  604.           for j := 0 to y do begin
  605.             { clear }
  606.               Buff [0] := 0;
  607.               Buff [1] := 0;
  608.               Buff [2] := 0;
  609.               n := 0;
  610.             { dest }
  611.               if Axis then D := @Dst [i]^[j]
  612.                  else D := @Dst [j]^[i];
  613.             { by list }
  614.               With List [j] do begin
  615.                    for k := 0 to Pred (Count) do begin
  616.                        With Pixels [k] do begin
  617.                           { source }
  618.                             if Axis then S := @Src [i]^[Place]
  619.                                else S := @Src [Place]^[i];
  620.                           { sum with quota }
  621.                             Inc (Buff [0], S^[0] * Quota);
  622.                             Inc (Buff [1], S^[1] * Quota);
  623.                             Inc (Buff [2], S^[2] * Quota);
  624.                             Inc (n, Quota);
  625.                        end; { With }
  626.                    end; { for }
  627.               end; { With }
  628.             { result }
  629.               if n > 0 then begin
  630.                  for k := 0 to 2 do begin
  631.                    { color }
  632.                      Buff [k] := Buff [k] div n;
  633.                    { range }
  634.                      if Buff [k] < 0 then D^[k] := 0
  635.                      else if Buff [k] > MaxByte then D^[k] := MaxByte
  636.                           else D^[k] := Buff [k];
  637.                  end; { for }
  638.               end { if }
  639.             { just in case }
  640.               else D^ := MinBGR;
  641.           end; { for }
  642.       end; { for }
  643.   end; { Apply }
  644.  
  645.  var
  646.      BufRows : TScanLines;
  647.      BmpRows : TScanLines;
  648.      Buffer  : TBitmap;
  649.      w, h    : integer;
  650.  begin
  651.      Result := true;
  652.    { nothing to do }
  653.      if (Width = Source.Width) and (Height = Source.Height) then begin
  654.         if TestDest (Source, Dest) then Dest.Assign (Source);
  655.         Exit;
  656.      end; { if }
  657.    { buffer }
  658.      Buffer := TBitmap.Create;
  659.      Try
  660.      { test }
  661.        TestSize (Height);
  662.        TestSize (Width);
  663.        TestSource (Source);
  664.      { init }
  665.        w := Source.Width;
  666.        h := Source.Height;
  667.        InitBmp (Buffer, Width, h);
  668.      { rows }
  669.        BmpScanLines (Source, BmpRows);
  670.        BmpScanLines (Buffer, BufRows);
  671.      { calc width }
  672.        Calc (w, Width);
  673.      { src -> buf }
  674.        Apply (h, Width, BmpRows, BufRows, true);
  675.      { target }
  676.        if TestDest (Source, Dest) then begin
  677.           InitBmp (Dest, Width, Height);
  678.           BmpScanLines (Dest, BmpRows);
  679.        end { if }
  680.        else begin
  681.             Source.Width := Width;
  682.             Source.Height := Height;
  683.             BmpScanLines (Source, BmpRows);
  684.        end; { else }
  685.      { calc height }
  686.        Calc (h, Height);
  687.      { buf -> target }
  688.        Apply (Width, Height, BufRows, BmpRows, false);
  689.      Except
  690.      { bugs or out of memory }
  691.        Result := false;
  692.      end; { try }
  693.    { free }
  694.      for h := 0 to Pred (Length (List)) do SetLength (List[h].Pixels, 0);
  695.      SetLength (List, 0);
  696.      SetLength (BmpRows, 0);
  697.      SetLength (BufRows, 0);
  698.      Buffer.Free;
  699.  end; { FilterResizeBmp }
  700.  
  701. (*************************************************************************)
  702. (*                              create thumbnail                         *)
  703. (*************************************************************************)
  704.  function ThumbnailBmp (Source, Dest: TBitmap; ScaleX, ScaleY: Single): boolean; overload;
  705.  
  706.   procedure InitDots (var Dots: array of integer; Scale: single);
  707.   var
  708.       i : integer;
  709.       q : single;
  710.   begin
  711.        q := 0;
  712.        for i := 0 to Pred (Length (Dots)) do begin
  713.            Dots [i] := Round (q);
  714.            q := q + Scale;
  715.        end; { for }
  716.   end; { InitDots }
  717.  
  718.  var
  719.      Rows : PScanLines;
  720.      DotX : array of integer;
  721.      DotY : array of integer;
  722.      Summ : TBGRSum;
  723.      Src  : TScanLines;
  724.      Dst  : TScanLines;
  725.      w, h : integer;
  726.      i, j : integer;
  727.      x, y : integer;
  728.      n, k : integer;
  729.      a, b : integer;
  730.      z    : integer;
  731.  begin
  732.    { init }
  733.      Result := true;
  734.    { nothing to do }
  735.      if (ScaleX = 1) and (ScaleY = 1) then begin
  736.         if TestDest (Source, Dest) then Dest.Assign (Source);
  737.         Exit;
  738.      end; { if }
  739.    { run }
  740.      Try
  741.      { test }
  742.        if (ScaleX < 1) or (ScaleY < 1) then Error;
  743.        TestSource (Source);
  744.      { size }
  745.        w := Source.Width;
  746.        h := Source.Height;
  747.      { new size }
  748.        y := Round (h / ScaleY);
  749.        x := Round (w / ScaleX);
  750.      { init }
  751.        BmpScanLines (Source, Src);
  752.        if TestDest (Source, Dest) then begin
  753.           InitBmp (Dest, x, y);
  754.           BmpScanLines (Dest, Dst);
  755.           Rows := @Dst;
  756.        end { if }
  757.        else Rows := @Src;
  758.      { y-dots }
  759.        SetLength (DotY, Succ (y));
  760.        InitDots (DotY, ScaleY);
  761.      { x-dots }
  762.        SetLength (DotX, Succ (x));
  763.        InitDots (DotX, ScaleX);
  764.      { y }
  765.        for j := 0 to Pred (y) do begin
  766.          { y-limit }
  767.            b := Pred (DotY [Succ (j)]);
  768.          { x }
  769.            for i := 0 to Pred (x) do begin
  770.              { x-limit }
  771.                a := Pred (DotX [Succ (i)]);
  772.              { clear }
  773.                Summ [0] := 0;
  774.                Summ [1] := 0;
  775.                Summ [2] := 0;
  776.                z := 0;
  777.              { y }
  778.                for k := DotY [j] to b do begin
  779.                  { range }
  780.                    if k < h then begin
  781.                     { x }
  782.                       for n := DotX [i] to a do begin
  783.                         { summ }
  784.                           if (n < w) then begin
  785.                              Inc (Summ [0], Src [k]^[n] [0]);
  786.                              Inc (Summ [1], Src [k]^[n] [1]);
  787.                              Inc (Summ [2], Src [k]^[n] [2]);
  788.                              Inc (z);
  789.                           end; { if }
  790.                       end; { for }
  791.                    end; { if }
  792.                end; { for }
  793.              { average }
  794.                Rows^[j]^[i] [0] := Summ [0] div z;
  795.                Rows^[j]^[i] [1] := Summ [1] div z;
  796.                Rows^[j]^[i] [2] := Summ [2] div z;
  797.            end; { for }
  798.        end; { for }
  799.      { set size }
  800.        if Rows = @Src then begin
  801.           Source.Height := y;
  802.           Source.Width := x;
  803.        end; { if }
  804.      Except
  805.      { bugs or out of memory }
  806.        Result := false;
  807.      end; { try }
  808.    { free }
  809.      SetLength (DotY, 0);
  810.      SetLength (DotX, 0);
  811.      SetLength (Src, 0);
  812.      SetLength (Dst, 0);
  813.  end; { ThumbnailBmp }
  814.  
  815.  function ThumbnailBmp (Bmp: TBitMap; Width, Height: word; AnchorX, AnchorY: TAnchor; Mode: boolean; const Fill: TColor = 0): boolean;
  816.  
  817.   function Offset (const Size, Limit: integer; const Anchor: TAnchor): integer;
  818.   begin
  819.       if Anchor > 0 then begin
  820.          Result := Abs (Size - Limit);
  821.          if Anchor = 1 then Result := Result shr 1;
  822.       end { if }
  823.       else Result := 0
  824.   end; { Offset }
  825.  
  826.  var
  827.      Buffer : TBitMap;
  828.      Src    : TRect;
  829.      Dst    : TRect;
  830.      Scale  : single;
  831.      w, h   : integer;
  832.      t, l   : integer;
  833.      x, y   : single;
  834.  begin
  835.      Result := true;
  836.    { nothing to do }
  837.      if (Width = Bmp.Width) and (Height = Bmp.Height) then Exit;
  838.    { test }
  839.      Try
  840.        TestSize (Height);
  841.        TestSize (Width);
  842.      Except
  843.        Result := false;
  844.        Exit;
  845.      end; { try }
  846.    { scale }
  847.      x := Bmp.Width / Width;
  848.      y := Bmp.Height / Height;
  849.      if Mode xor (x > y) then Scale := y
  850.         else Scale := x;
  851.    { buffer }
  852.      Buffer := TBitmap.Create;
  853.    { resize }
  854.      if ThumbnailBmp (Bmp, Buffer, Scale, Scale) then begin
  855.       { size }
  856.         w := Buffer.Width;
  857.         h := Buffer.Height;
  858.       { offset }
  859.         t := Offset (Height, h, AnchorY);
  860.         l := Offset (Width, w, AnchorX);
  861.       { move }
  862.         Dst := Rect (0, 0, Width, Height);
  863.         With Bmp.Canvas do begin
  864.            { fill }
  865.              if Mode then begin
  866.                 Brush.Color := Fill;
  867.                 FillRect (Dst);
  868.               { draw }
  869.                 Draw (l, t, Buffer);
  870.              end { if }
  871.            { cut }
  872.              else begin
  873.                   Src := Rect (l, t, Width + l, Height + t);
  874.                   CopyRect (Dst, Buffer.Canvas, Src);
  875.              end; { else }
  876.         end; { With }
  877.       { size }
  878.         Bmp.Height := Height;
  879.         Bmp.Width := Width;
  880.      end { if }
  881.      else Result := false;
  882.    { free }
  883.      Buffer.Free;
  884.  end; { ThumbnailBmp }
  885.  
  886. (*************************************************************************)
  887. (*                               compare image                           *)
  888. (*************************************************************************)
  889.  function BmpMatrix (Bmp: TBitMap; var Matrix: TMatrix): boolean;
  890.  var
  891.      Buff : TBitMap;
  892.      Rows : TScanLines;
  893.      i, j : integer;
  894.      a, b : integer;
  895.  begin
  896.    { init }
  897.      Buff := TBitMap.Create;
  898.      a := Bmp.Width;
  899.      b := Bmp.Height;
  900.    { decrease }
  901.      if ThumbnailBmp (Bmp, Buff,  a / MatrixLimit,  b / MatrixLimit) then begin
  902.       { ok }
  903.         Result := true;
  904.       { init }
  905.         FillChar (Matrix, SizeOf (Matrix), 0);
  906.         BmpScanLines (Buff, Rows);
  907.       { y }
  908.         for j := 0 to MatrixRight do begin
  909.           { prev }
  910.             a := 0;
  911.             Inc (a, Rows [j]^[MatrixRight] [0]);
  912.             Inc (a, Rows [j]^[MatrixRight] [1]);
  913.             Inc (a, Rows [j]^[MatrixRight] [2]);
  914.           { x }
  915.             for i := 0 to MatrixRight do begin
  916.               { curr }
  917.                 b := Rows [j]^[i][0] + Rows [j]^[i][1] + Rows [j]^[i][2];
  918.               { difference }
  919.                 Dec (a, b);
  920.               { levels }
  921.                 if a < 0 then Matrix [j] := Matrix [j] or (1 shl i);
  922.               { next }
  923.                 a := b;
  924.             end; { for }
  925.         end; { for }
  926.      end { if }
  927.      else Result := false;
  928.    { free }
  929.      SetLength (Rows, 0);
  930.      Buff.Free;
  931.  end; { BmpMatrix }
  932.  
  933.  function EquMatrix (First, Second : PMatrix; Likeness: byte): boolean;
  934.  
  935.    function TestLine (const F, S: longword): boolean;
  936.    var
  937.        k, n : longword;
  938.    begin
  939.      { init }
  940.        n := MatrixLimit;
  941.      { compare }
  942.        k := F xor S;
  943.      { test }
  944.        While (k <> 0) and (n >= Likeness) do begin
  945.          { not equ }
  946.            if Odd (k) then Dec (n);
  947.          { next }
  948.            k := k shr 1;
  949.        end; { for }
  950.        Result := (n >= Likeness);
  951.    end; { TestLine }
  952.  
  953.    function TestMatrix (var F, S: TMatrix): boolean;
  954.    var
  955.        j, n : integer;
  956.    begin
  957.        n := MatrixLimit;
  958.        j := 0;
  959.        While (j < MatrixLimit) and (n >= Likeness) do begin
  960.          { test }
  961.            if not TestLine (F [j], S [j]) then Dec (n);
  962.          { next }
  963.            Inc (j);
  964.        end; { While }
  965.        Result := (n >= Likeness);
  966.    end; { TestMatrix }
  967.  
  968.  begin
  969.    { likeness }
  970.      Likeness := (MatrixLimit * Likeness) div 100;
  971.    { compare }
  972.      Result := TestMatrix (First^, Second^);
  973.  end; { EquMatrix }
  974.  
  975.  End.
  976.  
  977.  
  978.  
  979.  
  980.