Sophie

Sophie

distrib > Fedora > 16 > i386 > by-pkgid > 243566e0c7bc06bb3f95bc8f63bfc1a2 > files > 9

perl-App-Asciio-1.02.71-9.fc16.noarch.rpm


use strict;
use warnings;
use lib qw(lib lib/stripes) ;

#--------------------------------------------------------------------------------------------

sub new_box
{
my (@arguments_to_constructor) = @_ ;

use App::Asciio::stripes::editable_box2 ;

my $box = new App::Asciio::stripes::editable_box2
				({
				TEXT_ONLY => 'box',
				TITLE => '',
				EDITABLE => 1,
				RESIZABLE => 1,
				@arguments_to_constructor,
				}) ;
				
return($box) ;
}

#-----------------------------------------------------------------------------------------------------------

sub new_wirl_arrow 
{
my (@arguments) = @_ ;

use App::Asciio::stripes::section_wirl_arrow ;
my $arrow = new App::Asciio::stripes::section_wirl_arrow
					({
					POINTS => [[5, 5, 'downright']],
					DIRECTION => '',
					ALLOW_DIAGONAL_LINES => 0,
					EDITABLE => 1,
					RESIZABLE => 1,
					@arguments,
					}) ;
}

#--------------------------------------------------------------------------------------------

sub add_connection
{
my ($self, $source_element, $destination_element, $hint, @arguments_to_constructor) = @_ ;

$hint ||= 'right-down' ;

my @destination_connections = grep {$_->{NAME} ne 'resize'} $destination_element->get_connection_points() ;
my $destination_connection = $destination_connections[0] ;

my @source_connections = grep {$_->{NAME} ne 'resize'} $source_element->get_connection_points() ;
my $source_connection = $source_connections[0] ;

my $new_element = new App::Asciio::stripes::section_wirl_arrow
					({
					POINTS => 
						[
							[
							    ($destination_element->{X} + $destination_connection->{X})
							  - ($source_element->{X} + $source_connection->{X}) ,
							
							    ($destination_element->{Y} + $destination_connection->{Y})
							 -  ($source_element->{Y} + $source_connection->{Y}) ,
							 
							$hint,
							]
						],
						
					DIRECTION => $hint,
					ALLOW_DIAGONAL_LINES => 0,
					EDITABLE => 1,
					RESIZABLE => 1,
					@arguments_to_constructor,
					}) ;
					
# let check_connection do the job of optimizing

@$new_element{'X', 'Y'} = ($source_element->{X} + $source_connection->{X}, $source_element->{Y} + $source_connection->{Y}) ;

$self->add_elements($new_element) ;
}

#--------------------------------------------------------------------------------------------

sub move_named_connector
{
my ($connected, $connector_name, $connectee, $connection_name) = @_ ;

do { die "Invalid argument to 'move_named_connector'!\n" unless defined $_}  for (@_) ;
die "Invalid number of arguments to 'move_named_connector'!\n" unless @_ == 4 ;
	
my $connector = $connected->get_named_connection($connector_name) ;
my $connection = $connectee->get_named_connection($connection_name) ;

if(defined $connector && defined $connection)
	{
	my $connector_x = $connected->{X} + $connector->{X} ;
	my $connector_y = $connected->{Y} + $connector->{Y} ;
	
	my $connection_x = $connectee->{X} + $connection->{X} ;
	my $connection_y = $connectee->{Y} + $connection->{Y} ;
	
	my $connector_x_offset = $connection_x - $connector_x ;
	my $connector_y_offset = $connection_y - $connector_y ;

	my ($x_offset, $y_offset, $width, $height, $new_connector) = 
		$connected->move_connector
			(
			$connector_name,
			$connector_x_offset, $connector_y_offset
			) ;
			
	$connected->{X} += $x_offset ;
	$connected->{Y} += $y_offset ;
	
	return 
		{
		CONNECTED => $connected,
		CONNECTOR =>$new_connector,
		CONNECTEE => $connectee,
		CONNECTION => $connection,
		} ;
	}
else
	{
	return ;
	}
}

#-----------------------------------------------------------------------------------------------------------

sub optimize_connections
{
my ($self) = @_;
$self->call_hook('CANONIZE_CONNECTIONS', $self->{CONNECTIONS}) ;
}

#--------------------------------------------------------------------------------------------

sub get_canonizer
{
my $context = new Eval::Context() ;

$context->eval
	(
	REMOVE_PACKAGE_AFTER_EVAL => 0, # VERY IMPORTANT as we return code references that will cease to exist otherwise
	PRE_CODE => <<'EOC' ,
use strict;
use warnings;

sub register_hooks
{
return \&canonize_connections ;
}

EOC
	CODE_FROM_FILE => 'setup/hooks/canonize_connections.pl' ,
	) ;
}


#--------------------------------------------------------------------------------------------

1 ;