Componentes.Terceros.jvcl/official/3.32/run/JvResample.pas

684 lines
20 KiB
ObjectPascal

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvResample.PAS released on 1998-03-15
The Initial Developer of the Original Code is Sébastien Buysse [sbuysse att buypin dott com]
Portions created by Anders Melander are Copyright (C) 1998 Anders Melander.
All Rights Reserved.
Contributor(s): -
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net
Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvResample.pas 10612 2006-05-19 19:04:09Z jfudickar $
// -----------------------------------------------------------------------------
// Project: bitmap resampler
// Module: resample
// Description: Interpolated Bitmap Resampling using filters.
// Version: 01.02
// Release: 3
// Date: 15-MAR-1998
// Target: Win32, Delphi 2 & 3
// Author(s): anme: Anders Melander, anders att melander dott dk
// Copyright (c) 1997,98 by Anders Melander
// Formatting: 2 space indent, no tabs, 80 columns.
// -----------------------------------------------------------------------------
// This software is copyrighted as noted above. It may be freely copied,
// modified, and redistributed, provided that the copyright notice(s) is
// preserved on all copies.
//
// There is no warranty or other guarantee of fitness for this software,
// it is provided solely "as is". Bug reports or fixes may be sent
// to the author, who may or may not act on them as he desires.
//
// You may not include this software in a program or other software product
// without supplying the source, or without informing the end-user that the
// source is available for no extra charge.
//
// If you modify this software, you should include a notice in the "Revision
// history" section giving the name of the person performing the modification,
// the date of modification, and the reason for such modification.
// -----------------------------------------------------------------------------
// Here's some additional copyrights for you:
//
// From filter.c:
// The authors and the publisher hold no copyright restrictions
// on any of these files; this source code is public domain, and
// is freely available to the entire computer graphics community
// for study, use, and modification. We do request that the
// comment at the top of each file, identifying the original
// author and its original publication in the book Graphics
// Gems, be retained in all programs that use these files.
//
// -----------------------------------------------------------------------------
// Revision history:
//
// 0100 110997 anme - Adapted from fzoom v0.20 by Dale Schumacher.
//
// 0101 110198 anme - Added Lanczos3 and Mitchell filters.
// - Fixed range bug.
// Min value was not checked on conversion from Single to
// byte.
// - Numerous optimizations.
// - Added TImage stretch on form resize.
// - Added support for Delphi 2 via TCanvas.Pixels.
// - Renamed module from stretch to resample.
// - Moved demo code to separate module.
//
// 0102 150398 anme - Fixed a problem that caused all pixels to be shifted
// 1/2 pixel down and to the right (in source
// coordinates). Thanks to David Ullrich for the
// solution.
// -----------------------------------------------------------------------------
// Credits:
// The algorithms and methods used in this library are based on the article
// "General Filtered Image Rescaling" by Dale Schumacher which appeared in the
// book Graphics Gems III, published by Academic Press, Inc.
//
// The edge offset problem was fixed by:
// * David Ullrich <ullrich att hardy dott math dott okstate dott edu>
// -----------------------------------------------------------------------------
// To do (in rough order of priority):
// * Implement Dale Schumacher's "Optimized Bitmap Scaling Routines".
// * Fix BoxFilter.
// * Optimize to use integer math instead of floating point where possible.
// -----------------------------------------------------------------------------
unit JvResample;
{$I jvcl.inc}
interface
uses
{$IFDEF UNITVERSIONING}
JclUnitVersioning,
{$ENDIF UNITVERSIONING}
Graphics, SysUtils, Classes;
type
// Type of a filter for use with Stretch()
TFilterProc = function(Value: Single): Single;
// Sample filters for use with Stretch()
function SplineFilter(Value: Single): Single;
function BellFilter(Value: Single): Single;
function TriangleFilter(Value: Single): Single;
function BoxFilter(Value: Single): Single;
function HermiteFilter(Value: Single): Single;
function Lanczos3Filter(Value: Single): Single;
function MitchellFilter(Value: Single): Single;
// Interpolator
// Src: Source bitmap
// Dst: Destination bitmap
// filter: weight calculation filter
// AWidth: Relative sample radius
procedure ImgStretch(Src, Dst: TBitmap; Filter: TFilterProc; AWidth: Single);
//----------------------------------------------------------------------------
// List of Filters
//----------------------------------------------------------------------------
const
ResampleFilters: array [0..6] of record
Name: string; // Filter name
Filter: TFilterProc; // Filter implementation
Width: Single; // Suggested sampling width/radius
end = (
(Name: 'Box'; Filter: BoxFilter; Width: 0.5),
(Name: 'Triangle'; Filter: TriangleFilter; Width: 1.0),
(Name: 'Hermite'; Filter: HermiteFilter; Width: 1.0),
(Name: 'Bell'; Filter: BellFilter; Width: 1.5),
(Name: 'B-Spline'; Filter: SplineFilter; Width: 2.0),
(Name: 'Lanczos3'; Filter: Lanczos3Filter; Width: 3.0),
(Name: 'Mitchell'; Filter: MitchellFilter; Width: 2.0)
);
{$IFDEF VisualCLX}
pf24bit = pf32bit;
{$ENDIF VisualCLX}
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvResample.pas $';
Revision: '$Revision: 10612 $';
Date: '$Date: 2006-05-19 21:04:09 +0200 (ven., 19 mai 2006) $';
LogPath: 'JVCL\run'
);
{$ENDIF UNITVERSIONING}
implementation
uses
Math,
JvTypes, JvResources;
//----------------------------------------------------------------------------
// Filter functions
//----------------------------------------------------------------------------
// Hermite filter
function HermiteFilter(Value: Single): Single;
begin
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
if Value < 0.0 then
Value := -Value;
if Value < 1.0 then
Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0
else
Result := 0.0;
end;
// Box filter
// a.k.a. "Nearest Neighbour" filter
// anme: I have not been able to get acceptable
// results with this filter for subsampling.
function BoxFilter(Value: Single): Single;
begin
if (Value > -0.5) and (Value <= 0.5) then
Result := 1.0
else
Result := 0.0;
end;
// Triangle filter
// a.k.a. "Linear" or "Bilinear" filter
function TriangleFilter(Value: Single): Single;
begin
if Value < 0.0 then
Value := -Value;
if Value < 1.0 then
Result := 1.0 - Value
else
Result := 0.0;
end;
// Bell filter
function BellFilter(Value: Single): Single;
begin
if Value < 0.0 then
Value := -Value;
if Value < 0.5 then
Result := 0.75 - Sqr(Value)
else
if Value < 1.5 then
begin
Value := Value - 1.5;
Result := 0.5 * Sqr(Value);
end
else
Result := 0.0;
end;
// B-spline filter
function SplineFilter(Value: Single): Single;
var
TT: Single;
begin
if Value < 0.0 then
Value := -Value;
if Value < 1.0 then
begin
TT := Sqr(Value);
Result := 0.5 * TT * Value - TT + 2.0 / 3.0;
end
else
if Value < 2.0 then
begin
Value := 2.0 - Value;
Result := 1.0 / 6.0 * Sqr(Value) * Value;
end
else
Result := 0.0;
end;
// Lanczos3 filter
function Lanczos3Filter(Value: Single): Single;
function SinC(Value: Single): Single;
begin
if Value <> 0.0 then
begin
Value := Value * Pi;
Result := Sin(Value) / Value
end
else
Result := 1.0;
end;
begin
if Value < 0.0 then
Value := -Value;
if Value < 3.0 then
Result := SinC(Value) * SinC(Value / 3.0)
else
Result := 0.0;
end;
function MitchellFilter(Value: Single): Single;
const
B = 1.0 / 3.0;
C = 1.0 / 3.0;
var
TT: Single;
begin
if Value < 0.0 then
Value := -Value;
TT := Sqr(Value);
if Value < 1.0 then
begin
Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * TT)) +
((-18.0 + 12.0 * B + 6.0 * C) * TT) +
(6.0 - 2 * B));
Result := Value / 6.0;
end
else
if Value < 2.0 then
begin
Value := (((-1.0 * B - 6.0 * C) * (Value * TT)) +
((6.0 * B + 30.0 * C) * TT) +
((-12.0 * B - 48.0 * C) * Value) +
(8.0 * B + 24 * C));
Result := Value / 6.0;
end
else
Result := 0.0;
end;
//----------------------------------------------------------------------------
// Interpolator
//----------------------------------------------------------------------------
type
// Contributor for a pixel
TContributor = record
Pixel: Integer; // Source pixel
Weight: Single; // Pixel Weight
end;
TContributorList = array [0..0] of TContributor;
PContributorList = ^TContributorList;
// List of source pixels contributing to a destination pixel
TCList = record
N: Integer;
P: PContributorList;
end;
TCListList = array [0..0] of TCList;
PCListList = ^TCListList;
TRGB = packed record
R: Single;
G: Single;
B: Single;
end;
// Physical bitmap pixel
TColorRGB = packed record
R: Byte;
G: Byte;
B: Byte;
end;
PColorRGB = ^TColorRGB;
// Physical bitmap scanline (row)
TRGBList = packed array [0..0] of TColorRGB;
PRGBList = ^TRGBList;
procedure ImgStretch(Src, Dst: TBitmap; Filter: TFilterProc; AWidth: Single);
var
XScale, YScale: Single; // Zoom scale factors
I, J, K: Integer; // Loop variables
Center: Single; // Filter calculation variables
Width, FScale, Weight: Single; // Filter calculation variables
Left, Right: Integer; // Filter calculation variables
N: Integer; // Pixel number
Work: TBitmap;
Contrib: PCListList;
Rgb: TRGB;
Color: TColorRGB;
SourceLine, DestLine: PRGBList;
SourcePixel, DestPixel: PColorRGB;
Delta, DestDelta: Integer;
SrcWidth, SrcHeight, DstWidth, DstHeight: Integer;
function Color2RGB(Color: TColor): TColorRGB;
begin
Result.R := Color and $000000FF;
Result.G := (Color and $0000FF00) shr 8;
Result.B := (Color and $00FF0000) shr 16;
end;
function RGB2Color(Color: TColorRGB): TColor;
begin
Result := Color.R or (Color.G shl 8) or (Color.B shl 16);
end;
begin
DstWidth := Dst.Width;
DstHeight := Dst.Height;
SrcWidth := Src.Width;
SrcHeight := Src.Height;
if (SrcWidth < 1) or (SrcHeight < 1) then
raise EJVCLException.CreateRes(@RsESourceBitmapTooSmall);
// Create intermediate image to hold horizontal zoom
Work := TBitmap.Create;
try
Work.Height := SrcHeight;
Work.Width := DstWidth;
// XScale := DstWidth / SrcWidth;
// YScale := DstHeight / SrcHeight;
// Improvement suggested by David Ullrich:
if SrcWidth = 1 then
XScale := DstWidth / SrcWidth
else
XScale := (DstWidth - 1) / (SrcWidth - 1);
if SrcHeight = 1 then
YScale := DstHeight / SrcHeight
else
YScale := (DstHeight - 1) / (SrcHeight - 1);
// This implementation only works on 24-bit images because it uses
// TBitmap.Scanline
Src.PixelFormat := pf24bit;
Dst.PixelFormat := Src.PixelFormat;
Work.PixelFormat := Src.PixelFormat;
// --------------------------------------------
// Pre-calculate filter contributions for a row
// -----------------------------------------------
GetMem(Contrib, DstWidth * SizeOf(TCList));
// Horizontal sub-sampling
// Scales from bigger to smaller Width
if XScale < 1.0 then
begin
Width := AWidth / XScale;
FScale := 1.0 / XScale;
for I := 0 to DstWidth - 1 do
begin
Contrib^[I].N := 0;
GetMem(Contrib^[I].P, Trunc(Width * 2.0 + 1) * SizeOf(TContributor));
Center := I / XScale;
// Original code:
// Left := Ceil(Center - Width);
// Right := Floor(Center + Width);
Left := Floor(Center - Width);
Right := Ceil(Center + Width);
for J := Left to Right do
begin
Weight := Filter((Center - J) / FScale) / FScale;
if Weight = 0.0 then
Continue;
if J < 0 then
N := -J
else
if J >= SrcWidth then
N := SrcWidth - J + SrcWidth - 1
else
N := J;
K := Contrib^[I].N;
Contrib^[I].N := Contrib^[I].N + 1;
Contrib^[I].P^[K].Pixel := N;
Contrib^[I].P^[K].Weight := Weight;
end;
end;
end
else
// Horizontal super-sampling
// Scales from smaller to bigger Width
begin
for I := 0 to DstWidth - 1 do
begin
Contrib^[I].N := 0;
GetMem(Contrib^[I].P, Trunc(AWidth * 2.0 + 1) * SizeOf(TContributor));
Center := I / XScale;
// Original code:
// Left := Ceil(Center - AWidth);
// Right := Floor(Center + AWidth);
Left := Floor(Center - AWidth);
Right := Ceil(Center + AWidth);
for J := Left to Right do
begin
Weight := Filter(Center - J);
if Weight = 0.0 then
Continue;
if J < 0 then
N := -J
else
if J >= SrcWidth then
N := SrcWidth - J + SrcWidth - 1
else
N := J;
K := Contrib^[I].N;
Contrib^[I].N := Contrib^[I].N + 1;
Contrib^[I].P^[K].Pixel := N;
Contrib^[I].P^[K].Weight := Weight;
end;
end;
end;
// ----------------------------------------------------
// Apply filter to sample horizontally from Src to Work
// ----------------------------------------------------
for K := 0 to SrcHeight - 1 do
begin
SourceLine := Src.ScanLine[K];
DestPixel := Work.ScanLine[K];
for I := 0 to DstWidth - 1 do
begin
Rgb.R := 0.0;
Rgb.G := 0.0;
Rgb.B := 0.0;
for J := 0 to Contrib^[I].N - 1 do
begin
Color := SourceLine^[Contrib^[I].P^[J].Pixel];
Weight := Contrib^[I].P^[J].Weight;
if Weight = 0.0 then
Continue;
Rgb.R := Rgb.R + Color.R * Weight;
Rgb.G := Rgb.G + Color.G * Weight;
Rgb.B := Rgb.B + Color.B * Weight;
end;
if Rgb.R > 255.0 then
Color.R := 255
else
if Rgb.R < 0.0 then
Color.R := 0
else
Color.R := Round(Rgb.R);
if Rgb.G > 255.0 then
Color.G := 255
else
if Rgb.G < 0.0 then
Color.G := 0
else
Color.G := Round(Rgb.G);
if Rgb.B > 255.0 then
Color.B := 255
else
if Rgb.B < 0.0 then
Color.B := 0
else
Color.B := Round(Rgb.B);
// Set new Pixel value
DestPixel^ := Color;
// Move on to next column
Inc(DestPixel);
end;
end;
// Free the memory allocated for horizontal filter weights
for I := 0 to DstWidth - 1 do
FreeMem(Contrib^[I].P);
FreeMem(Contrib);
// -----------------------------------------------
// Pre-calculate filter contributions for a column
// -----------------------------------------------
GetMem(Contrib, DstHeight * SizeOf(TCList));
// Vertical sub-sampling
// Scales from bigger to smaller height
if YScale < 1.0 then
begin
Width := AWidth / YScale;
FScale := 1.0 / YScale;
for I := 0 to DstHeight - 1 do
begin
Contrib^[I].N := 0;
GetMem(Contrib^[I].P, Trunc(Width * 2.0 + 1) * SizeOf(TContributor));
Center := I / YScale;
// Original code:
// Left := Ceil(Center - Width);
// Right := Floor(Center + Width);
Left := Floor(Center - Width);
Right := Ceil(Center + Width);
for J := Left to Right do
begin
Weight := Filter((Center - J) / FScale) / FScale;
if Weight = 0.0 then
Continue;
if J < 0 then
N := -J
else
if J >= SrcHeight then
N := SrcHeight - J + SrcHeight - 1
else
N := J;
K := Contrib^[I].N;
Contrib^[I].N := Contrib^[I].N + 1;
Contrib^[I].P^[K].Pixel := N;
Contrib^[I].P^[K].Weight := Weight;
end;
end
end
else
// Vertical super-sampling
// Scales from smaller to bigger height
begin
for I := 0 to DstHeight - 1 do
begin
Contrib^[I].N := 0;
GetMem(Contrib^[I].P, Trunc(AWidth * 2.0 + 1) * SizeOf(TContributor));
Center := I / YScale;
// Original code:
// Left := Ceil(Center - AWidth);
// Right := Floor(Center + AWidth);
Left := Floor(Center - AWidth);
Right := Ceil(Center + AWidth);
for J := Left to Right do
begin
Weight := Filter(Center - J);
if Weight = 0.0 then
Continue;
if J < 0 then
N := -J
else
if J >= SrcHeight then
N := SrcHeight - J + SrcHeight - 1
else
N := J;
K := Contrib^[I].N;
Contrib^[I].N := Contrib^[I].N + 1;
Contrib^[I].P^[K].Pixel := N;
Contrib^[I].P^[K].Weight := Weight;
end;
end;
end;
// --------------------------------------------------
// Apply filter to sample vertically from Work to Dst
// --------------------------------------------------
SourceLine := Work.ScanLine[0];
Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine);
DestLine := Dst.ScanLine[0];
DestDelta := Integer(Dst.ScanLine[1]) - Integer(DestLine);
for K := 0 to DstWidth - 1 do
begin
DestPixel := Pointer(DestLine);
for I := 0 to DstHeight - 1 do
begin
Rgb.R := 0;
Rgb.G := 0;
Rgb.B := 0;
// Weight := 0.0;
for J := 0 to Contrib^[I].N - 1 do
begin
Color := PColorRGB(Integer(SourceLine) + Contrib^[I].P^[J].Pixel * Delta)^;
Weight := Contrib^[I].P^[J].Weight;
if Weight = 0.0 then
Continue;
Rgb.R := Rgb.R + Color.R * Weight;
Rgb.G := Rgb.G + Color.G * Weight;
Rgb.B := Rgb.B + Color.B * Weight;
end;
if Rgb.R > 255.0 then
Color.R := 255
else
if Rgb.R < 0.0 then
Color.R := 0
else
Color.R := Round(Rgb.R);
if Rgb.G > 255.0 then
Color.G := 255
else
if Rgb.G < 0.0 then
Color.G := 0
else
Color.G := Round(Rgb.G);
if Rgb.B > 255.0 then
Color.B := 255
else
if Rgb.B < 0.0 then
Color.B := 0
else
Color.B := Round(Rgb.B);
DestPixel^ := Color;
Inc(Integer(DestPixel), DestDelta);
end;
Inc(SourceLine, 1);
Inc(DestLine, 1);
end;
// Free the memory allocated for vertical filter weights
for I := 0 to DstHeight - 1 do
FreeMem(Contrib^[I].P);
FreeMem(Contrib);
finally
Work.Free;
end;
end;
{$IFDEF UNITVERSIONING}
initialization
RegisterUnitVersion(HInstance, UnitVersioning);
finalization
UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}
end.