#!/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');
}