[perl-Cairo] Add a pixel snapping example

[Torsten Schönfeld <tsch src gnome org>]

commit 8ab39594e18881a144f4f5594a9e63ad5aa3e2df
Author: Torsten Schönfeld <kaffeetisch gmx de>
Date:   Tue May 11 01:26:01 2010 +0200

    Add a pixel snapping example

 examples/snapping.pl |  363 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 363 insertions(+), 0 deletions(-)
---
diff --git a/examples/snapping.pl b/examples/snapping.pl
new file mode 100644
index 0000000..6b07b38
--- /dev/null
+++ b/examples/snapping.pl
@@ -0,0 +1,363 @@
+#!/usr/bin/perl
+
+# This is a Perl port of the C program cairo-demo/png/snapping.c.  Original
+# copyright:
+
+# Copyright (c) 2004 Red Hat, Inc.
+#
+# Permission to use, copy, modify, distribute, and sell this software
+# and its documentation for any purpose is hereby granted without
+# fee, provided that the above copyright notice appear in all copies
+# and that both that copyright notice and this permission notice
+# appear in supporting documentation, and that the name of
+# Red Hat, Inc. not be used in advertising or publicity pertaining to
+# distribution of the software without specific, written prior
+# permission. Red Hat, Inc. makes no representations about the
+# suitability of this software for any purpose.  It is provided "as
+# is" without express or implied warranty.
+#
+# RED HAT, INC. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS
+# SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
+# FITNESS, IN NO EVENT SHALL RED HAT, INC. BE LIABLE FOR ANY SPECIAL,
+# INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
+# RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION
+# OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR
+# IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+#
+# Author: Carl D. Worth <cworth cworth org>
+
+use strict;
+use warnings;
+use Cairo;
+use POSIX qw(floor);
+
+# This demo demonstrates how to perform device-pixel snapping for
+# horizontal and vertically aligned strokes and fills. The technique
+# used here is designed to work with any stroke width as well as any
+# scale factor or translation amount in the current transformation.
+# The code here may not provide good results for curved objects or
+# when the transformation includes rotation and or shear components.
+#
+# The output includes four groups of nested boxes. The top two groups
+# consists of 5 filled boxes, alternating between black and
+# white. The bottom two groups show 5 white stroked boxes. Within
+# each group, the path for each box is constructed the same way, but
+# with a different transform. For the two groups on the right, all
+# coordinates in the path are snapped before drawing so that the
+# boundary of each shape will align properly with the device pixel
+# grid.
+
+use constant
+{
+	WIDTH => 175,
+	HEIGHT => 175,
+};
+
+# These snapping functions are designed to work properly with a
+# matrix that has only scale and translate components. I make no
+# guarantees about how they will behave under more interesting
+# transformations (such as rotation or shear).
+
+# Snap the given coordinate so that it is on an integer coordinate of
+# the device pixel grid. This is the appropriate snapping to use for
+# horizontal/vertical portions of paths to be filled.
+sub snap_point_for_fill
+{
+	my ($cr, $x, $y) = @_;
+
+	# Convert to device space, round, then convert back to user space.
+	($x, $y) = $cr->user_to_device ($x, $y);
+	$x = floor ($x + 0.5);
+	$y = floor ($y + 0.5);
+	($x, $y) = $cr->device_to_user ($x, $y);
+
+	return ($x, $y);
+}
+
+# Snap the given path coordinate as appropriate for a path to be
+# stroked. This snapping is dependent on the current line width, so
+# it should be called when the line width is set to the value that
+# will be used for the stroke.
+#
+# The snapping is performed so that the stroke boundary of horizontal
+# and vertical portions will lie precisely between device pixels. If
+# the device-space line width is not an integer, then only one side
+# of the path will be properly aligned. The snap_line_width function
+# below can be used to constrain the line width to be an integer in
+# device space.
+sub snap_point_for_stroke
+{
+	my ($cr, $x, $y) = @_;
+
+	# Round in device space after adding the fractional portion of
+	# one-half the (device space) line width.
+	my $x_width_dev_2 = $cr->get_line_width;
+	my $y_width_dev_2 = $cr->get_line_width;
+	($x_width_dev_2, $y_width_dev_2) =
+		$cr->user_to_device_distance ($x_width_dev_2, $y_width_dev_2);
+	$x_width_dev_2 *= 0.5;
+	$y_width_dev_2 *= 0.5;
+
+	my $x_offset = $x_width_dev_2 - int $x_width_dev_2;
+	my $y_offset = $y_width_dev_2 - int $y_width_dev_2;
+
+	($x, $y) = $cr->user_to_device ($x, $y);
+	$x = floor ($x + $x_offset + 0.5);
+	$y = floor ($y + $y_offset + 0.5);
+	$x -= $x_offset;
+	$y -= $y_offset;
+	($x, $y) = $cr->device_to_user ($x, $y);
+
+	return ($x, $y);
+}
+
+# Snap the line width so that it is an integer number of device
+# pixels. Cairo currently only supports symmetrical pens, so if the
+# current transformation has non-uniform scaling in X and Y, we won't
+# be able to satisfy the constraint in both dimensions. So, this
+# function examines both directions and snaps to the dimension that
+# has the larger error.
+sub snap_line_width
+{
+	my ($cr) = @_;
+
+	my $x_width = $cr->get_line_width;
+	my $y_width = $cr->get_line_width;
+
+	($x_width, $y_width) = $cr->user_to_device_distance ($x_width, $y_width);
+
+	# If the line width is less than 1 then it will round to 0 and
+	# disappear. Instead, we clamp it to 1.0, but we must preserve
+	# its sign for the case of a reflecting transformation.
+	my $x_width_snapped = floor ($x_width + 0.5);
+	if (abs ($x_width_snapped) < 1.0) {
+		$x_width_snapped = $x_width > 0 ? 1.0 : -1.0;
+	}
+
+	my $y_width_snapped = floor ($y_width + 0.5);
+	if (abs ($y_width_snapped) < 1.0) {
+		$y_width_snapped = $y_width > 0 ? 1.0 : -1.0;
+	}
+
+	my $x_error = abs ($x_width - $x_width_snapped);
+	my $y_error = abs ($y_width - $y_width_snapped);
+
+	($x_width_snapped, $y_width_snapped) =
+		$cr->device_to_user_distance
+			($x_width_snapped, $y_width_snapped);
+
+	$cr->set_line_width
+		($x_error > $y_error ? $x_width_snapped : $y_width_snapped);
+}
+
+sub snap_point
+{
+	my ($spc, $x, $y) = @_;
+
+	return $spc->{fill}
+		? snap_point_for_fill ($spc->{cr}, $x, $y)
+		: snap_point_for_stroke ($spc->{cr}, $x, $y);
+}
+
+sub spc_new_path_perhaps
+{
+	my ($spc) = @_;
+
+	if ($spc->{first}) {
+		$spc->{cr}->new_path;
+		$spc->{first} = 0;
+	}
+}
+
+sub spc_move_to
+{
+	my ($spc, $x, $y) = @_;
+
+	spc_new_path_perhaps ($spc);
+	($x, $y) = snap_point ($spc, $x, $y);
+	$spc->{cr}->move_to ($x, $y);
+}
+
+sub spc_line_to
+{
+	my ($spc, $x, $y) = @_;
+
+	spc_new_path_perhaps ($spc);
+	($x, $y) = snap_point ($spc, $x, $y);
+	$spc->{cr}->line_to ($x, $y);
+}
+
+sub spc_curve_to
+{
+	my ($spc, $x1, $y1, $x2, $y2, $x3, $y3) = @_;
+
+	spc_new_path_perhaps ($spc);
+	($x1, $y1) = snap_point ($spc, $x1, $y1);
+	($x2, $y2) = snap_point ($spc, $x2, $y2);
+	($x3, $y3) = snap_point ($spc, $x3, $y3);
+	$spc->{cr}->curve_to ($x1, $y1, $x2, $y2, $x3, $y3);
+}
+
+sub spc_close_path
+{
+	my ($spc) = @_;
+
+	spc_new_path_perhaps ($spc);
+	$spc->{cr}->close_path;
+}
+
+sub snap_path_for_fill
+{
+	my ($cr) = @_;
+
+	my $spc = {
+		first => 1,
+		fill => 1,
+		cr => $cr,
+	};
+
+	my $path = $cr->copy_path;
+	use Data::Dumper;
+	foreach (@{$path}) {
+		if ($_->{type} eq 'move-to') {
+			spc_move_to ($spc, @{$_->{points}->[0]});
+		}
+
+		elsif ($_->{type} eq 'line-to') {
+			spc_line_to ($spc, @{$_->{points}->[0]});
+		}
+
+		elsif ($_->{type} eq 'curve-to') {
+			spc_curve_to ($spc, @{$_->{points}->[0]},
+			                    @{$_->{points}->[1]},
+			                    @{$_->{points}->[2]});
+		}
+
+		else {
+			spc_close_path ($spc);
+		}
+	}
+}
+
+sub snap_path_for_stroke
+{
+	my ($cr) = @_;
+
+	my $spc = {
+		first => 1,
+		fill => 0,
+		cr => $cr,
+	};
+
+	snap_line_width ($cr);
+
+	my $path = $cr->copy_path;
+	use Data::Dumper;
+	foreach (@{$path}) {
+		if ($_->{type} eq 'move-to') {
+			spc_move_to ($spc, @{$_->{points}->[0]});
+		}
+
+		elsif ($_->{type} eq 'line-to') {
+			spc_line_to ($spc, @{$_->{points}->[0]});
+		}
+
+		elsif ($_->{type} eq 'curve-to') {
+			spc_curve_to ($spc, @{$_->{points}->[0]},
+			                    @{$_->{points}->[1]},
+			                    @{$_->{points}->[2]});
+		}
+
+		else {
+			spc_close_path ($spc);
+		}
+	}
+}
+
+use constant {
+	NUM_BOXES => 5,
+	BOX_WIDTH => 13,
+	# We need non-integer scale factors to demonstrate anything
+	# interesting.
+	SCALE_TWEAK => 1.11,
+};
+
+sub draw_nested
+{
+	my ($cr, $style, $snapping) = @_;
+	my $offset = SCALE_TWEAK * BOX_WIDTH / 2.0;
+
+	$cr->save;
+
+	$cr->set_line_width (1.0);
+
+	foreach (0 .. NUM_BOXES - 1) {
+		my $scale = SCALE_TWEAK * (NUM_BOXES - $_);
+
+		$cr->save;
+		{
+			$cr->scale ($scale, $scale);
+			$cr->rectangle (0, 0, BOX_WIDTH, BOX_WIDTH);
+
+			if ($style eq 'nested-fills') {
+				if ($snapping eq 'snapping') {
+					snap_path_for_fill ($cr);
+				}
+
+				if ($_ % 2 == 0) {
+					$cr->set_source_rgb (1, 1, 1);
+				} else {
+					$cr->set_source_rgb (0, 0, 0);
+				}
+
+				$cr->fill;
+			} else {
+				if ($snapping eq 'snapping') {
+					snap_path_for_stroke ($cr);
+				}
+
+				$cr->set_source_rgb (1, 1, 1);
+				$cr->stroke;
+			}
+		}
+		$cr->restore;
+
+		$cr->translate ($offset, $offset);
+	}
+
+	$cr->restore;
+}
+
+sub draw
+{
+	my ($cr, $width, $height) = @_;
+
+	$cr->translate (6, 6);
+
+	draw_nested ($cr, 'nested-fills', 'no-snapping');
+
+	$cr->translate ($width / 2, 0);
+
+	draw_nested ($cr, 'nested-fills', 'snapping');
+
+	$cr->translate (-$width / 2, $height / 2);
+
+	draw_nested ($cr, 'nested-strokes', 'no-snapping');
+
+	$cr->translate ($width / 2, 0);
+
+	draw_nested ($cr, 'nested-strokes', 'snapping');
+}
+
+{
+	my $surface = Cairo::ImageSurface->create ('argb32', WIDTH, HEIGHT);
+	my $cr = Cairo::Context->create ($surface);
+
+	$cr->rectangle (0, 0, WIDTH, HEIGHT);
+	$cr->set_source_rgb (0, 0, 0);
+	$cr->fill;
+
+	draw ($cr, WIDTH, HEIGHT);
+
+	$surface->write_to_png ('snapping.png');
+}