Viewing file:  canvas.pl (45.61 KB) -rw-r--r--
Select action/file-type:
 (+) |  (+) |  (+) | Code (+) | Session (+) |  (+) | SDB (+) |  (+) |  (+) |  (+) |  (+) |  (+) |
use strict;
use warnings;
use Prima qw(ScrollWidget);
# A widget with two scrollbars. Contains set of objects, that know
# how to draw themselves. The graphic objects hierarchy starts
# from Prima::CanvasObject:: class
package Prima::Canvas;
use vars qw(@ISA);
@ISA = qw(Prima::ScrollWidget);
sub profile_default
{
return {
%{$_[ 0]-> SUPER::profile_default},
zoom => 1,
paneSize => [ 0, 0],
paneWidth => 0,
paneHeight => 0,
alignment => ta::Left,
valignment => ta::Bottom,
selectable => 1,
}
}
sub profile_check_in
{
my ( $self, $p, $default) = @_;
$self-> SUPER::profile_check_in( $p, $default);
if ( exists( $p-> { paneSize})) {
$p-> { paneWidth} = $p-> { paneSize}-> [ 0];
$p-> { paneHeight} = $p-> { paneSize}-> [ 1];
}
}
sub init
{
my ( $self, %profile) = @_;
$self-> {zoom} = 1;
$self-> {$_} = 0 for qw(paneWidth paneHeight alignment valignment);
$self-> {objects} = [];
%profile = $self-> SUPER::init(%profile);
$self-> $_($profile{$_}) for qw(zoom paneWidth paneHeight alignment valignment);
return %profile;
}
sub on_paint
{
my ( $self, $canvas) = @_;
$canvas-> clear;
my $zoom = $self-> {zoom};
my @c = $canvas-> clipRect;
my %props;
my %defaults = map { $_ => $canvas-> $_() } @Prima::CanvasObject::uses;
for my $obj ( @{$self-> {objects}}) {
my @r = $self-> object2screen( $obj-> rect, $obj-> inner_rect);
$r[$_]-- for 2,3;
next if !$obj-> visible ||
$r[0] > $c[2] || $r[1] > $c[3] ||
$r[2] < $c[0] || $r[3] < $c[1];
my @uses = $obj-> uses;
delete @props{@uses};
my $f = $obj-> font;
$canvas-> set(
(map { $_ => $obj-> $_() } @uses),
(map { $_ => $defaults{$_} } keys %props)
);
%props = map { $_ => 1 } @uses;
$canvas-> translate( @r[4,5]);
$canvas-> clipRect( @r[0..3]);
$obj-> on_paint( $canvas, $r[6]-$r[4], $r[7]-$r[5]);
}
$canvas-> translate(0,0);
$canvas-> clipRect(@c);
}
sub on_mousedown
{
my ( $self, $btn, $mod, $x, $y) = @_;
$self-> propagate_mouse_event( 'on_mousedown', $x, $y, $btn, $mod, $x, $y);
}
sub on_mouseup
{
my ( $self, $btn, $mod, $x, $y) = @_;
$self-> propagate_mouse_event( 'on_mouseup', $x, $y, $btn, $mod, $x, $y);
}
sub on_mousemove
{
my ( $self, $mod, $x, $y) = @_;
$self-> propagate_mouse_event( 'on_mousemove', $x, $y, $mod, $x, $y);
}
sub on_mouseclick
{
my ( $self, $btn, $mod, $x, $y, $dbl) = @_;
$self-> propagate_mouse_event( 'on_mousemove', $x, $y, $mod, $x, $y, $dbl);
}
sub on_keydown
{
my ( $self, $code, $key, $mod, $repeat) = @_;
$self-> propagate_event( nt::Command, 'on_keydown', $code, $key, $mod, $repeat);
}
sub on_keyup
{
my ( $self, $code, $key, $mod) = @_;
$self-> propagate_event( nt::Command, 'on_keyup', $code, $key, $mod);
}
sub delete_object
{
my ( $self, $obj) = ( shift, shift);
@{$self-> {objects}} = grep { $_ != $obj } @{$self-> {objects}};
$self-> {selection} = undef
if $self-> {selection} && $self-> {selection} == $obj;
my @r = $self-> object2screen( $obj-> rect);
$self-> invalidate_rect( @r) if $obj-> visible;
}
sub insert_object
{
my ( $self, $class) = ( shift, shift);
my $obj;
$self-> attach_object( $obj = $class-> new(
@_,
owner => $self,
));
$obj;
}
sub attach_object
{
push @{$_[0]-> {objects}}, $_[1];
$_[1]-> {owner} = $_[0];
$_[1]-> repaint;
}
sub object2screen
{
my $self = $_[0];
my $i;
my @d = $self-> deltas;
my ( $ha, $va) = ( $self-> {alignment}, $self-> {valignment});
my ($x, $y) = $self-> get_active_area(2);
my @l = $self-> limits;
if ( $l[0] < $x) {
if ( $ha == ta::Left) {
} elsif ( $ha != ta::Right) {
$d[0] -= ($x - $l[0])/2;
} else {
$d[0] -= $x - $l[0];
}
}
if ( $l[1] < $y) {
if ( $va == ta::Top) {
$d[1] -= $y - $l[1];
} elsif ( $va != ta::Bottom) {
$d[1] -= ($y - $l[1])/2;
}
} else {
$d[1] = $l[1] - $y - $d[1];
}
$d[$_] -= $self-> {indents}-> [$_] for 0,1;
my $zoom = $self-> {zoom};
my @ret;
for ( $i = 1; $i <= $#_; $i+=2) {
push @ret, $_[$i] * $zoom - $d[0];
push @ret, $_[$i+1] * $zoom - $d[1] if defined $_[$i+1];
}
return map {
( $_ < 0) ?
int( $_ - .5) :
int( $_ + .5)
} @ret;
}
sub screen2object
{
my $self = $_[0];
my $i;
my @d = $self-> deltas;
my ( $ha, $va) = ( $self-> {alignment}, $self-> {valignment});
my ($x, $y) = $self-> get_active_area(2);
my @l = $self-> limits;
if ( $l[0] < $x) {
if ( $ha == ta::Left) {
} elsif ( $ha != ta::Right) {
$d[0] -= ($x - $l[0])/2;
} else {
$d[0] -= $x - $l[0];
}
}
if ( $l[1] < $y) {
if ( $va == ta::Top) {
$d[1] -= $y - $l[1];
} elsif ( $va != ta::Bottom) {
$d[1] -= ($y - $l[1])/2;
}
} else {
$d[1] = $l[1] - $y - $d[1];
}
my $zoom = $self-> {zoom};
my @ret;
$d[$_] -= $self-> {indents}-> [$_] for 0,1;
for ( $i = 1; $i <= $#_; $i+=2) {
push @ret, ($_[$i] + $d[0]) / $zoom;
push @ret, ($_[$i+1] + $d[1]) / $zoom if defined $_[$i+1];
}
@ret;
}
sub position2object
{
my ( $self, $x, $y, $skip_hittest) = @_;
my ( $nx, $ny) = $self-> screen2object( $x, $y);
$self-> push_event;
for my $obj ( reverse @{$self-> {objects}}) {
next unless $obj-> visible;
my @r = $obj-> rect;
if ( $r[0] <= $nx && $r[1] <= $ny && $r[2] >= $nx && $r[3] >= $ny) {
my @s = $self-> object2screen(@r[0,1]);
if ( $skip_hittest || $obj-> on_hittest( $x - $s[0], $y - $s[1])) {
$self-> pop_event;
return ($obj, $x - $s[0], $y - $s[1]);
}
}
}
$self-> pop_event;
return;
}
sub propagate_mouse_event
{
my ( $self, $event, $x, $y, @params) = @_;
my ( $obj, $nx, $ny) = $self-> position2object( $x, $y);
return unless $obj;
$self-> push_event;
$obj-> $event( @params);
$self-> pop_event;
}
sub propagate_event
{
my ( $self, $flow, $event, @params) = @_;
$self-> push_event;
my $stop = $flow & nt::SMASK;
for (
( $flow & nt::FluxReverse) ?
$self-> objects :
reverse $self-> objects
) {
$_-> $event( @params);
last if
( $stop == nt::Single) ||
( $stop == nt::Event && !$self-> eventFlag);
}
$self-> pop_event;
}
sub reset_zoom
{
my ( $self ) = @_;
$self-> limits(
$self-> {paneWidth} * $self-> {zoom},
$self-> {paneHeight} * $self-> {zoom}
);
}
sub alignment
{
return $_[0]-> {alignment} unless $#_;
$_[0]-> {alignment} = $_[1];
$_[0]-> repaint;
}
sub valignment
{
return $_[0]-> {valignment} unless $#_;
$_[0]-> {valignment} = $_[1];
$_[0]-> repaint;
}
sub paneWidth
{
return $_[0]-> {paneWidth} unless $#_;
my ( $self, $pw) = @_;
$pw = 0 if $pw < 0;
return if $pw == $self-> {paneWidth};
$self-> {paneWidth} = $pw;
$self-> reset_zoom;
$self-> repaint;
}
sub paneHeight
{
return $_[0]-> {paneHeight} unless $#_;
my ( $self, $ph) = @_;
$ph = 0 if $ph < 0;
return if $ph == $self-> {paneHeight};
$self-> {paneHeight} = $ph;
$self-> reset_zoom;
$self-> repaint;
}
sub paneSize
{
return $_[0]-> {paneWidth}, $_[0]-> {paneHeight} if $#_ < 2;
my ( $self, $pw, $ph) = @_;
$ph = 0 if $ph < 0;
$pw = 0 if $pw < 0;
return if $ph == $self-> {paneHeight} && $pw == $self-> {paneWidth};
$self-> {paneWidth} = $pw;
$self-> {paneHeight} = $ph;
$self-> reset_zoom;
$self-> repaint;
}
sub zoom
{
return $_[0]-> {zoom} unless $#_;
my ( $self, $zoom) = @_;
return if $zoom == $self-> {zoom};
$self-> {zoom} = $zoom;
$self-> reset_zoom;
$self-> reset_layout;
$self-> repaint;
}
sub set_deltas
{
my $self = shift;
$self-> SUPER::set_deltas(@_);
$self-> reset_layout;
}
sub reset_layout
{
$_[0]-> propagate_event( nt::Notification, 'on_layoutchanged');
}
sub zorder
{
my ( $self, $obj, $command) = @_;
my $idx;
my $o = $self-> {objects};
if ( $command ne 'first' and $command ne 'last') {
for ( $idx = 0; $idx < @$o; $idx++) {
last if $obj == $$o[$idx];
}
return if $idx == @$o;
}
if ( $command eq 'front') {
@$o = grep { $_ != $obj } @$o;
push @$o, $obj;
} elsif ( $command eq 'back') {
@$o = grep { $_ != $obj } @$o;
unshift @$o, $obj;
} elsif ( $command eq 'first') {
return $$o[0];
} elsif ( $command eq 'last') {
return $$o[-1];
} elsif ( $command eq 'next') {
return $$o[$idx+1];
} elsif ( $command eq 'prev') {
return $idx ? $$o[$idx-1] : undef;
} else {
my $i;
my @o = grep { $_ != $obj } @$o;
return if @o == @$o;
@$o = @o;
for ( $i = 0; $i < @$o; $i++) {
next unless $$[$i] != $command;
splice @$o, $i, 0, $obj;
last;
}
}
$obj-> on_zorderchanged();
$obj-> repaint;
}
sub objects {@{$_[0]-> {objects}}}
package Prima::CanvasEdit;
use vars qw(@ISA);
@ISA = qw(Prima::Canvas);
sub on_paint
{
my ( $self, $canvas) = @_;
$self-> SUPER::on_paint( $canvas);
$canvas-> set(
linePattern => lp::Solid,
rop => rop::CopyPut,
lineWidth => 0,
color => 0,
);
my @r = $self-> object2screen( 0, 0, $self-> paneSize);
$canvas-> rectangle( $r[0]-1, $r[1]-1, $r[2], $r[3]);
return unless $self-> {selection};
@r = $self-> object2screen($self-> {selection}-> rect);
$r[2]--;
$r[3]--;
$canvas-> rect_focus(@r);
}
sub on_mousedown
{
my ( $self, $btn, $mod, $x, $y) = @_;
my $found;
if ( $btn == mb::Left && !$self-> {transaction}) {
my ( $obj, $nx, $ny) = $self-> position2object( $x, $y);
if ( $obj) {
$self-> {anchor} = [ $nx, $ny ];
$obj-> bring_to_front;
$self-> focused_object( $found = $self-> {transaction} = $obj);
$self-> capture(1, $self);
}
}
$self-> focused_object(undef) if $self-> {selection} && !$found;
$self-> SUPER::on_mousedown( $btn, $mod, $x, $y);
}
sub on_mouseup
{
my ( $self, $btn, $mod, $x, $y) = @_;
if ( $self-> {transaction} && $btn == mb::Left) {
$self-> {transaction} = undef;
$self-> capture(0);
}
$self-> SUPER::on_mouseup( $btn, $mod, $x, $y);
}
sub on_mousemove
{
my ( $self, $mod, $x, $y) = @_;
if ( $self-> {transaction}) {
my @p = $self-> paneSize;
$x -= $self-> {anchor}-> [0];
$y -= $self-> {anchor}-> [1];
my @o = $self-> screen2object( $x, $y);
my @s = $self-> {transaction}-> size;
for ( 0..1) {
$o[$_] = 0 if $o[$_] < 0;
$o[$_] = $p[$_] - $s[$_] - 1 if $o[$_] >= $p[$_] - $s[$_];
}
$self-> {transaction}-> origin( @o);
}
$self-> SUPER::on_mousemove( $mod, $x, $y);
}
sub on_keydown
{
my ( $self, $code, $key, $mod, $repeat) = @_;
if ( $key == kb::Tab || $key == kb::BackTab) {
my $new = $self-> focused_object;
if ( $key == kb::Tab) {
$new = $self-> zorder( $new, $new ? 'prev' : 'last');
$new = $self-> zorder( undef, 'last') unless $new;
} else {
$new = $self-> zorder( $new, $new ? 'next' : 'first');
$new = $self-> zorder( undef, 'first') unless $new;
}
if ( $new) {
$self-> focused_object( $new);
$self-> clear_event;
return;
}
}
if ( $key == kb::Left || $key == kb::Right || $key == kb::Up || $key == kb::Down) {
my $obj = $self-> focused_object;
if ( $obj) {
my ( $dx, $dy) = (0,0);
if ( $key == kb::Left) {
$dx = -5;
} elsif ( $key == kb::Right) {
$dx = +5;
} elsif ( $key == kb::Down) {
$dy = -5;
} elsif ( $key == kb::Up) {
$dy = +5;
}
my @sz = $obj-> size;
$sz[0] += $dx;
$sz[1] += $dy;
$sz[0] = 5 if $sz[0] < 5;
$sz[1] = 5 if $sz[1] < 5;
$obj-> size( @sz);
}
}
$self-> SUPER::on_keydown( $code, $key, $mod, $repeat);
}
sub focused_object
{
return $_[0]-> {selection} unless $#_;
return if $_[1] && $_[1]-> owner != $_[0];
$_[0]-> {selection}-> repaint if $_[0]-> {selection};
$_[0]-> {selection} = $_[1];
$_[0]-> {selection}-> repaint if $_[0]-> {selection};
}
package Prima::CanvasObject;
use vars qw(%defaults @uses %list_properties);
{
@uses = qw( backColor color fillPattern font lineEnd linePattern
lineWidth region rop rop2 textOpaque
textOutBaseline lineJoin fillMode);
my $pd = Prima::Drawable-> profile_default();
%defaults = map { $_ => $pd-> {$_} } @uses;
%list_properties = map { $_ => 1 } qw(origin size rect resolution);
}
sub new
{
my ( $class, %properties) = @_;
my $self = bless {}, $class;
$self-> lock;
$self-> {adjust_in_progress} = 1;
my %defaults = $self-> profile_default;
$self-> {$_} = $defaults{$_} for keys %defaults;
$self-> {font} = {%{$defaults{font}}};
$self-> {indents} = [0,0,0,0];
$self-> init( \%defaults, \%properties);
$self-> set(%properties);
$self-> on_create;
delete $self-> {adjust_in_progress};
$self-> adjust( exists $properties{size} or exists $properties{rect});
$self-> unlock;
return $self;
}
sub init
{
my ( $self, $defaults, $properties) = @_;
}
sub DESTROY { shift-> on_destroy; }
sub destroy
{
my $self = $_[0];
$self-> owner( undef);
}
sub profile_default
{
%defaults,
origin => [ 0, 0],
size => [ 100, 100],
visible => 1,
name => '',
resolution => [1,1],
autoAdjust => 1,
}
sub uses
{
return ();
}
sub set
{
my $self = shift;
my $i;
for ( $i = 0; $i < @_; $i+=2) {
my ( $prop, $val) = @_[$i,$i+1];
if ( $list_properties{$prop}) {
$self-> $prop( @$val);
} else {
$self-> $prop( $val);
}
}
}
sub clear_event
{
$_[0]-> {owner}-> clear_event if $_[0]-> {owner};
}
sub on_create
{
}
sub on_destroy
{
}
sub on_hittest
{
my ( $self, $x, $y) = @_;
1;
}
sub on_keydown
{
my ( $self, $code, $key, $mod, $repeat) = @_;
}
sub on_keyup
{
my ( $self, $code, $key, $mod) = @_;
}
sub on_mousedown
{
my ( $self, $btn, $mod, $x, $y) = @_;
}
sub on_mouseup
{
my ( $self, $btn, $mod, $x, $y) = @_;
}
sub on_mousemove
{
my ( $self, $mod, $x, $y) = @_;
}
sub on_mouseclick
{
my ( $self, $btn, $mod, $x, $y, $dbl) = @_;
}
sub on_move
{
my ( $self, $oldx, $oldy, $x, $y) = @_;
}
sub on_size
{
my ( $self, $oldx, $oldy, $x, $y) = @_;
}
sub on_adjust_data
{
my ( $self, $x, $y) = @_;
}
sub on_adjust_size
{
my ( $self) = @_;
}
sub on_layoutchanged
{
my ( $self) = @_;
}
sub on_zorderchanged
{
my ( $self) = @_;
}
sub on_paint
{
my ( $self, $canvas, $width, $heigth) = @_;
}
sub on_render
{
my ($self) = @_;
}
sub repaint
{
delete $_[0]-> {_update} if $_[0]-> {_update};
$_[0]-> _update( $_[0]-> origin, $_[0]-> size);
}
sub invalidate_rect
{
my ( $self, $x1, $y1, $x2, $y2) = @_;
my @o = $self-> origin;
$self-> _update( $o[0] + $x1, $o[1] + $y1, $x2 - $x1 + 1, $y2 - $y1 + 1);
}
sub resolution
{
return @{$_[0]-> {resolution}} unless $#_;
my ( $self, $x, $y) = @_;
return if $x == $self-> {resolution}-> [0] && $y == $self-> {resolution}-> [1];
$self-> {resolution} = [$x, $y];
$self-> on_render();
}
sub _begin_update
{
my $self = $_[0];
return if !$self-> {visible} || $self-> {_lock_update};
$self-> {_update} = [];
}
sub _update
{
my ( $self, $x, $y, $w, $h) = @_;
return unless $self-> {visible};
my $auto = ! $self-> {_update};
push @{$self-> {_update}}, $x, $y, $x + $w, $y + $h;
$self-> _end_update if $auto && !$self-> {_lock_update};
}
sub _end_update
{
my $self = $_[0];
return if !$self-> {visible} || $self-> {_lock_update} || !$self-> {_update} || !$self-> {owner};
my $o = $self-> {owner};
my @o = $o-> object2screen( @{$self-> {_update}});
my $i;
for ($i = 0; $i < @o; $i+=4) {
$o-> invalidate_rect( @o[$i..$i+3]);
}
delete $self-> {_update};
}
sub name { $#_ ? $_[0]-> {name} = $_[1] : $_[0]-> {name} }
sub lock { $_[0]-> {_lock_update}++ }
sub unlock
{
return unless $_[0]-> {_lock_update};
$_[0]-> _end_update unless --$_[0]-> {_lock_update};
}
sub owner
{
return $_[0]-> {owner} unless $#_;
$_[0]-> {owner}-> delete_object( $_[0]) if $_[0]-> {owner};
$_[0]-> {owner} = undef;
$_[1]-> attach_object( $_[0]) if $_[1];
}
sub left
{
$#_ ?
$_[0]-> origin( $_[1], $_[0]-> {origin}-> [1]) :
$_[0]-> {origin}-> [0]
}
sub bottom
{
$#_ ?
$_[0]-> origin( $_[0]-> {origin}-> [0], $_[1]) :
$_[0]-> {origin}-> [1]
}
sub right
{
$#_ ?
$_[0]-> size( $_[1] - $_[0]-> {origin}-> [0], $_[0]-> {size}-> [1]) :
$_[0]-> {origin}-> [0] + $_[0]-> {size}-> [0]
}
sub top
{
$#_ ?
$_[0]-> size( $_[1] - $_[0]-> {origin}-> [0], $_[0]-> {size}-> [1]) :
$_[0]-> {origin}-> [0] + $_[0]-> {size}-> [0]
}
sub width
{
$#_ ?
$_[0]-> size( $_[1], $_[0]-> {size}-> [0]) :
$_[0]-> {size}-> [0]
}
sub height
{
$#_ ?
$_[0]-> size( $_[0]-> {size}-> [1], $_[1]) :
$_[0]-> {size}-> [1]
}
sub rect
{
unless ( $#_) {
my @o = @{$_[0]-> {origin}};
my @s = @{$_[0]-> {size}};
return @o, $s[0] + $o[0], $s[1] + $o[1];
}
my ( $self, $x1, $y1, $x2, $y2) = @_;
( $x1, $x2) = ( $x2, $x1) if $x2 > $x1;
( $y1, $y2) = ( $y2, $y1) if $y2 > $y1;
$self-> lock;
$self-> origin( $x1, $y1);
$self-> size( $x2 - $x1, $y2 - $y1);
$self-> unlock;
}
sub origin
{
return @{$_[0]-> {origin}} unless $#_;
my ( $self, $x, $y) = @_;
return if $x == $self-> {origin}-> [0] and $y == $self-> {origin}-> [1];
my @o = @{$self-> {origin}};
$self-> _begin_update;
$self-> _update( @{$self-> {origin}}, @{$self-> {size}});
@{$self-> {origin}} = ( $x, $y);
$self-> _update( @{$self-> {origin}}, @{$self-> {size}});
$self-> on_move( @o, $x, $y);
$self-> _end_update;
}
sub size
{
return @{$_[0]-> {size}} unless $#_;
my ( $self, $x, $y) = @_;
$x = 0 if $x < 0;
$y = 0 if $y < 0;
return if $x == $self-> {size}-> [0] and $y == $self-> {size}-> [1];
my @s = @{$self-> {size}};
$self-> _begin_update;
$self-> _update( @{$self-> {origin}}, @{$self-> {size}});
@{$self-> {size}} = ( $x, $y);
$self-> _update( @{$self-> {origin}}, @{$self-> {size}});
$self-> adjust( 1) unless $self-> {adjust_flag};
$self-> on_size( @s, $x, $y);
$self-> _end_update;
}
sub inner_size
{
return map {
$_[0]-> {size}-> [$_] - $_[0]-> {indents}-> [$_] - $_[0]-> {indents}-> [$_+2]
} 0, 1 unless $#_;
my ( $self, $x, $y) = @_;
$x += $self-> {indents}-> [0] + $self-> {indents}-> [2];
$y += $self-> {indents}-> [1] + $self-> {indents}-> [3];
my $adjust_flag = $self-> {adjust_flag};
$self-> {adjust_flag} = 1;
$self-> size( $x, $y);
$self-> {adjust_flag} = $adjust_flag;
}
sub inner_rect
{
return
$_[0]-> {origin}-> [0] + $_[0]-> {indents}-> [0],
$_[0]-> {origin}-> [1] + $_[0]-> {indents}-> [1],
$_[0]-> {origin}-> [0] + $_[0]-> {size}-> [0] - $_[0]-> {indents}-> [2],
$_[0]-> {origin}-> [1] + $_[0]-> {size}-> [1] - $_[0]-> {indents}-> [3],
unless $#_;
my ( $self, $x1, $y1, $x2, $y2) = @_;
$x1 -= $self-> {indents}-> [0];
$y1 -= $self-> {indents}-> [1];
$x2 += $self-> {indents}-> [2];
$y2 += $self-> {indents}-> [3];
my $adjust_flag = $self-> {adjust_flag};
$self-> {adjust_flag} = 1;
$self-> rect( $x1, $y1, $x2, $y2);
$self-> {adjust_flag} = $adjust_flag;
}
sub indents
{
return @{$_[0]-> {indents}} unless $#_;
my ( $self, @indents) = @_;
@indents = @{$indents[0]} unless $#indents;
$self-> origin(
$self-> {origin}-> [0] + $self-> {indents}-> [0] - $indents[0],
$self-> {origin}-> [1] + $self-> {indents}-> [1] - $indents[1]
);
@{$self-> {indents}} = @indents;
}
sub adjust
{
my ( $self, $data_from_size) = @_;
return if $self-> {adjust_in_progress} or !$self-> {autoAdjust};
$self-> {adjust_in_progress} = 1;
$self-> lock;
$data_from_size ?
$self-> on_adjust_data(@{$self-> {size}}) :
$self-> on_adjust_size();
$self-> unlock;
delete $self-> {adjust_in_progress};
}
sub autoAdjust
{
return $_[0]-> {autoAdjust} unless $#_;
$_[0]-> {autoAdjust} = $_[1];
}
sub bring_to_front { $_[0]-> {owner}-> zorder( $_[0], 'front') if $_[0]-> {owner} }
sub send_to_back { $_[0]-> {owner}-> zorder( $_[0], 'back') if $_[0]-> {owner} }
sub insert_behind { $_[0]-> {owner}-> zorder( $_[0], $_[1]) if $_[0]-> {owner} }
sub first { $_[0]-> {owner}-> zorder( $_[0], 'first') if $_[0]-> {owner} }
sub last { $_[0]-> {owner}-> zorder( $_[0], 'last') if $_[0]-> {owner} }
sub next { $_[0]-> {owner}-> zorder( $_[0], 'next') if $_[0]-> {owner} }
sub prev { $_[0]-> {owner}-> zorder( $_[0], 'prev') if $_[0]-> {owner} }
sub visible
{
return $_[0]-> {visible} unless $#_;
return if $_[0]-> {visible} == $_[1];
$_[0]-> {visible} = $_[1];
$_[0]-> {owner}-> invalidate_rect( $_[0]-> owner-> object2screen( $_[0]-> rect))
if $_[0]-> {owner};
}
sub color
{
return $_[0]-> {color} unless $#_;
$_[0]-> {color} = $_[1];
$_[0]-> repaint;
}
sub backColor
{
return $_[0]-> {backColor} unless $#_;
$_[0]-> {backColor} = $_[1];
$_[0]-> repaint;
}
sub fillPattern
{
return $_[0]-> {fillPattern} unless $#_;
$_[0]-> {fillPattern} = $_[1];
$_[0]-> repaint;
}
sub font
{
return $_[0]-> {font} unless $#_;
my ( $self, $font) = @_;
for ( keys %$font) {
$self-> {font}-> {$_} = $font-> {$_};
}
$_[0]-> repaint;
}
sub lineWidth
{
return $_[0]-> {lineWidth} unless $#_;
$_[0]-> {lineWidth} = $_[1];
$_[0]-> repaint;
}
sub linePattern
{
return $_[0]-> {linePattern} unless $#_;
$_[0]-> {linePattern} = $_[1];
$_[0]-> repaint;
}
sub lineEnd
{
return $_[0]-> {lineEnd} unless $#_;
$_[0]-> {lineEnd} = $_[1];
$_[0]-> repaint;
}
sub lineJoin
{
return $_[0]-> {lineJoin} unless $#_;
$_[0]-> {lineJoin} = $_[1];
$_[0]-> repaint;
}
sub fillMode
{
return $_[0]-> {fillMode} unless $#_;
$_[0]-> {fillMode} = $_[1];
$_[0]-> repaint;
}
sub rop
{
return $_[0]-> {rop} unless $#_;
$_[0]-> {rop} = $_[1];
$_[0]-> repaint;
}
sub rop2
{
return $_[0]-> {rop2} unless $#_;
$_[0]-> {rop2} = $_[1];
$_[0]-> repaint;
}
sub textOutBaseline
{
return $_[0]-> {textOutBaseline} unless $#_;
$_[0]-> {textOutBaseline} = $_[1];
$_[0]-> repaint;
}
sub textOpaque
{
return $_[0]-> {textOpaque} unless $#_;
$_[0]-> {textOpaque} = $_[1];
$_[0]-> repaint;
}
package Prima::Canvas::Outlined;
use vars qw(@ISA);
@ISA = qw(Prima::CanvasObject);
sub uses { return qw( rop rop2 backColor color lineWidth linePattern lineEnd); }
package Prima::Canvas::Filled;
use vars qw(@ISA);
@ISA = qw(Prima::CanvasObject);
sub uses { return qw( rop rop2 color backColor fillPattern lineEnd); }
package Prima::Canvas::FilledOutlined;
use vars qw(@ISA);
@ISA = qw(Prima::CanvasObject);
sub profile_default
{
$_[0]-> SUPER::profile_default,
fill => 1,
outline => 1,
fillBackColor => cl::Black,
outlineBackColor => cl::Black,
}
sub uses {
my $self = $_[0];
my @ret = qw(rop rop2 color backColor);
push @ret, qw(lineWidth linePattern lineEnd) if $self-> {outline};
push @ret, qw(fillPattern) if $self-> {fill};
@ret;
}
sub fill
{
return $_[0]-> {fill} unless $#_;
return if $_[0]-> {fill} == $_[1];
$_[0]-> {fill} = $_[1];
$_[0]-> repaint;
}
sub outline
{
return $_[0]-> {outline} unless $#_;
return if $_[0]-> {outline} == $_[1];
$_[0]-> {outline} = $_[1];
$_[0]-> repaint;
}
sub fillBackColor
{
return $_[0]-> {fillBackColor} unless $#_;
return if $_[0]-> {fillBackColor} == $_[1];
$_[0]-> {fillBackColor} = $_[1];
$_[0]-> repaint;
}
sub outlineBackColor
{
return $_[0]-> {outlineBackColor} unless $#_;
return if $_[0]-> {outlineBackColor} == $_[1];
$_[0]-> {outlineBackColor} = $_[1];
$_[0]-> repaint;
}
package Prima::Canvas::Rectangle;
use vars qw(@ISA);
@ISA = qw(Prima::Canvas::FilledOutlined);
sub on_paint
{
my ( $self, $canvas, $width, $height) = @_;
if ( $self-> {fill}) {
$canvas-> color( $self-> {backColor});
$canvas-> backColor( $self-> {fillBackColor});
$canvas-> bar( 0, 0, $width - 1, $height - 1);
}
if ( $self-> {outline}) {
my $lw1 = int(($self-> {lineWidth} || 1) / 2);
my $lw2 = int((($self-> {lineWidth} || 1) - 1) / 2) + 1;
$canvas-> color( $self-> {color});
$canvas-> backColor( $self-> {outlineBackColor});
$canvas-> rectangle( $lw1, $lw1, $width - $lw2, $height - $lw2);
}
}
package Prima::Canvas::Ellipse;
use vars qw(@ISA);
@ISA = qw(Prima::Canvas::FilledOutlined);
sub on_paint
{
my ( $self, $canvas, $width, $height) = @_;
my ( $cx, $cy) = (int(($width - 1) / 2), int(($height - 1)/ 2));
if ( $self-> {fill}) {
$canvas-> color( $self-> {backColor});
$canvas-> backColor( $self-> {fillBackColor});
$canvas-> fill_ellipse( $cx, $cy, $width, $height);
}
if ( $self-> {outline}) {
my $lw = ($self-> {lineWidth} || 1) - 1;
$canvas-> color( $self-> {color});
$canvas-> backColor( $self-> {outlineBackColor});
$canvas-> ellipse( $cx, $cy, $width - $lw, $height - $lw);
}
}
package Prima::Canvas::arc_properties;
sub start
{
return $_[0]-> {start} unless $#_;
$_[0]-> {start} = $_[1];
$_[0]-> repaint;
}
sub end
{
return $_[0]-> {end} unless $#_;
$_[0]-> {end} = $_[1];
$_[0]-> repaint;
}
package Prima::Canvas::Arc;
use vars qw(@ISA);
@ISA = qw(Prima::Canvas::Outlined Prima::Canvas::arc_properties);
sub profile_default
{
$_[0]-> SUPER::profile_default,
start => 0,
end => 90,
}
sub on_paint
{
my ( $self, $canvas, $width, $height) = @_;
my ( $cx, $cy) = (int(($width - 1) / 2), int(($height - 1)/ 2));
my $lw = ($self-> {lineWidth} || 1) - 1;
$canvas-> arc( $cx, $cy, $width - $lw, $height - $lw, $self-> {start}, $self-> {end});
}
package Prima::Canvas::FilledArc;
use vars qw(@ISA);
@ISA = qw(Prima::Canvas::FilledOutlined Prima::Canvas::arc_properties);
sub profile_default
{
$_[0]-> SUPER::profile_default,
start => 0,
end => 90,
mode => 'chord',
}
sub on_paint
{
my ( $self, $canvas, $width, $height) = @_;
my ( $cx, $cy) = (int(($width - 1) / 2), int(($height - 1)/ 2));
my $mode1 = ($self-> {mode} eq 'chord') ? 'chord' : 'sector';
my $mode2 = ($self-> {mode} eq 'chord') ? 'fill_chord' : 'fill_sector';
if ( $self-> {fill}) {
$canvas-> color( $self-> {backColor});
$canvas-> backColor( $self-> {fillBackColor});
$canvas-> $mode2( $cx, $cy, $width, $height, $self-> {start}, $self-> {end});
}
if ( $self-> {outline}) {
my $lw = ($self-> {lineWidth} || 1) - 1;
$canvas-> color( $self-> {color});
$canvas-> backColor( $self-> {outlineBackColor});
$canvas-> $mode1( $cx, $cy, $width - $lw, $height - $lw, $self-> {start}, $self-> {end});
}
}
package Prima::Canvas::Chord;
use vars qw(@ISA);
@ISA = qw(Prima::Canvas::FilledArc);
package Prima::Canvas::Sector;
use vars qw(@ISA);
@ISA = qw(Prima::Canvas::FilledArc);
sub profile_default
{
$_[0]-> SUPER::profile_default,
mode => 'sector',
}
package Prima::Canvas::line_properties;
sub points
{
return $_[0]-> {points} unless $#_;
my $self = shift;
my $p = ( defined($_[0]) && ref($_[0]) eq 'ARRAY') ? $_[0] : \@_;
die "Number of points is not multiple of 2" if @$p % 2;
push @$p, @$p[0,1]
if $self-> {fix_last_point} && ( $$p[0] != $$p[-2] || $$p[1] != $$p[1]);
$self-> {points} = $p;
$self-> adjust;
}
sub zoom_points
{
my ( $self, $w, $h) = @_;
my ( $x, $y) = $self-> inner_size;
return [] if $w < 1 || $h < 1 || $x < 1 || $y < 1;
unless ( defined $self-> {cosa}) {
my $a = $self-> {rotate} / 57.295779;
$self-> {cosa} = cos( $a);
$self-> {sina} = sin( $a);
}
my ( $cos, $sin) = ( $self-> {cosa}, $self-> {sina});
my @anchor = @{$self-> {anchor}};
my @aspect = @{$self-> {aspect}};
my @shift = @{$self-> {shift}};
my @offset = ($self-> {offset} && $self-> {autoAdjust}) ? @{$self-> {offset}} : (0,0);
$x /= $w;
$y /= $h;
$h = $self-> {points};
my @ret;
for ( $w = 0; $w < @$h; $w += 2) {
my $X = $$h[$w] - $anchor[0] + $shift[0];
my $Y = $$h[$w+1] - $anchor[1] + $shift[1];
my $A = ($X * $cos - $Y * $sin);
my $B = ($X * $sin + $Y * $cos);
$A = ( $A + $anchor[0]) * $aspect[0] + $offset[0];
$B = ( $B + $anchor[1]) * $aspect[1] + $offset[1];
push @ret, $A / $x;
push @ret, $B / $y;
}
\@ret;
}
sub extents
{
my ( $self, $points) = @_;
my $p;
if ( $points) {
$p = $points;
} else {
local $self-> {offset};
$p = $self-> zoom_points( $self-> inner_size);
}
my $lw = int(($self-> lineWidth || 1) / 2);
return -$lw,-$lw,$lw,$lw if 0 == @$p;
my $i;
my @r = @$p[0,1,0,1];
for ( $i = 2; $i < @$p; $i += 2) {
$r[0] = $$p[$i] if $r[0] > $$p[$i];
$r[1] = $$p[$i+1] if $r[1] > $$p[$i+1];
$r[2] = $$p[$i] if $r[2] < $$p[$i];
$r[3] = $$p[$i+1] if $r[3] < $$p[$i+1];
}
$r[$_] -= $lw, $r[$_+2] += $lw for 0,1;
return @r;
}
sub anchor
{
return @{$_[0]-> {anchor}} unless $#_;
$_[0]-> {anchor} = [($#_ == 1) ? @{$_[1]} : @_[1,2]];
$_[0]-> adjust;
}
sub aspect
{
return @{$_[0]-> {aspect}} unless $#_;
$_[0]-> {aspect} = [(($#_ == 1) ? @{$_[1]} : @_[1,2])];
$_[0]-> adjust;
}
sub shift
{
return @{$_[0]-> {shift}} unless $#_;
$_[0]-> {shift} = [($#_ == 1) ? @{$_[1]} : @_[1,2]];
$_[0]-> adjust;
}
sub smooth
{
return $_[0]-> {smooth} unless $#_;
$_[0]-> {smooth} = $_[1];
$_[0]-> repaint;
}
sub rotate
{
return $_[0]-> {rotate} unless $#_;
my ( $self, $angle) = @_;
$angle += 360 while $angle < 0;
$angle %= 360;
return if $self-> {rotate} == $angle;
$self-> {rotate} = $angle;
delete $self-> {sina};
delete $self-> {cosa};
$self-> adjust;
}
package Prima::Canvas::Line;
use vars qw(@ISA %arrowheads);
@ISA = qw(Prima::Canvas::Outlined Prima::Canvas::line_properties);
%arrowheads = (
feather => [1,0, -1,-1,-0.5,-0.7,-0.15,-0.4, 0,0, -0.15, 0.4, -0.5,0.7,-1,1, 1,0],
default => [1,0, -1,-1, -1,1, 1,0],
flying => [1,0, -1,-1, 0,0, -1,1, 1,0],
square => [0.5,0, 0,-0.5, -0.5,-0.5, 0, 0, -0.5, 0.5, 0,0.5, 0.5,0],
);
sub profile_default
{
$_[0]-> SUPER::profile_default,
anchor => [0,0],
aspect => [1,1],
shift => [0,0],
arrows => [undef,undef],
points => [],
smooth => 0,
rotate => 0,
}
sub uses
{
my $self = $_[0];
my @ret = $self-> SUPER::uses;
push @ret, 'lineJoin';
@ret;
}
sub arrows
{
return @{$_[0]-> {arrows}} unless $#_;
my $self = $_[0];
$self-> lock;
my @arrows = ($#_ == 1) ? @{$_[1]} : @_[1,2];
$self-> arrow( $_, $arrows[$_]) for 0, 1;
$self-> unlock;
}
sub arrow
{
return $_[0]-> {arrows}-> [$_[1]] if $#_ == 1;
my ( $self, $idx, $arrow) = @_;
return if $idx < 0 || $idx > 1;
my $mul;
if ( defined ($arrow) && (!ref($arrow) || ref($arrow) eq 'ARRAY')) {
unless (ref($arrow)) {
if ( $arrow =~ /^([^\:]*)\:(\-?[\d\.]+)$/) {
( $arrow,$mul) = ($1,$2);
goto ASPECT if !length $arrow && $self-> {arrows}-> [$idx];
}
$arrow = exists ($arrowheads{$arrow}) ?
$arrowheads{$arrow} :
$arrowheads{default};
}
if ( defined $self-> {arrows}-> [$idx] && $self-> {arrows}-> [$idx]-> isa('Prima::Canvas::Polygon')) {
$self-> {arrows}-> [$idx]-> points( $arrow);
} else {
$self-> {arrows}-> [$idx] = Prima::Canvas::Polygon-> new(
points => $arrow,
fill => 1,
outline => 0,
);
}
ASPECT:
$self-> {arrows}-> [$idx]-> aspect( $mul, $mul) if defined $mul;
} else {
$self-> {arrows}-> [$idx] = $arrow;
}
$self-> {arrows}-> [$idx]-> autoAdjust( 0) if $self-> {arrows}-> [$idx];
$self-> adjust;
}
sub on_adjust_size
{
my ( $self) = @_;
delete $self-> {offset};
my $p = $self-> zoom_points( $self-> inner_size);
my @inner = $self-> extents( $p);
$inner[$_+2] -= $inner[$_] for 0,1;
my @delta = @inner[0,1];
$self-> {offset} = [map {-1*$_} @delta];
@inner[0,1] = (0,0);
my @outer = @inner;
my $flip = 0;
my $lw = ($self-> {lineWidth} || 1);
for ( 0..1) {
my ( $x1, $y1, $x2, $y2) = @$p[ $flip++ ? (2,3,0,1) : (-4..-1)];
next unless $_ = $self-> {arrows}-> [$_];
$_-> rotate( atan2($y2 - $y1, $x2 - $x1) * 57.295779);
my @r = map { $_ * $lw } $_-> extents;
my @arrow_box = ( $x2 + $r[0] - $delta[0], $y2 + $r[1] - $delta[1],
$x2 + $r[2] - $delta[0], $y2 + $r[3] - $delta[1]);
for ( 0,1) {
$outer[$_] = $arrow_box[$_] if $outer[$_] > $arrow_box[$_];
$outer[$_+2] = $arrow_box[$_+2] if $outer[$_+2] < $arrow_box[$_+2];
}
}
$self-> indents(
$inner[0] - $outer[0],
$inner[1] - $outer[1],
$outer[2] - $inner[2],
$outer[3] - $inner[3],
);
$self-> inner_size( @inner[2,3]);
}
sub on_adjust_data
{
my ( $self, $x, $y) = @_;
}
sub on_paint
{
my ( $self, $canvas, $width, $height) = @_;
my $lw = ($self-> {lineWidth} || 1);
my @size = $self-> inner_size;
my $p = $self-> zoom_points( $width, $height);
return if 4 > @$p;
$canvas-> lineWidth( $self-> lineWidth * $width / int $size[0]);
$self-> {smooth} ?
$canvas-> spline( $p) :
$canvas-> polyline( $p);
my $flip = 0;
my @t = $canvas-> translate;
for my $arrow ( @{$self-> {arrows}}) {
my ( $x1, $y1, $x2, $y2) = @$p[ $flip++ ? (2,3,0,1) : (-4..-1)];
next unless $arrow;
my @asize = $arrow-> size;
$canvas-> translate( $t[0] + $x2, $t[1] + $y2);
$arrow-> set(
rotate => atan2($y2 - $y1, $x2 - $x1) * 57.295779,
backColor => $canvas-> color,
);
$arrow-> on_paint( $canvas,
$lw * $width * $asize[0] / int $size[0],
$lw * $height * $asize[1] / int $size[1]);
}
}
sub lineWidth
{
return $_[0]-> SUPER::lineWidth unless $#_;
my $self = shift;
$self-> SUPER::lineWidth(@_);
$self-> adjust;
}
package Prima::Canvas::Polygon;
use vars qw(@ISA);
@ISA = qw(Prima::Canvas::FilledOutlined Prima::Canvas::line_properties);
sub profile_default
{
$_[0]-> SUPER::profile_default,
anchor => [0,0],
aspect => [1,1],
shift => [0,0],
points => [],
smooth => 0,
rotate => 0,
fix_last_point => 1,
}
sub uses
{
my $self = $_[0];
my @ret = $self-> SUPER::uses;
push @ret, 'lineJoin' if $self-> {outline};
push @ret, 'fillMode' if $self-> {fill};
@ret;
}
sub on_paint
{
my ( $self, $canvas, $width, $height) = @_;
my $p = $self-> zoom_points( $width, $height);
return unless @$p;
if ( $self-> {fill}) {
$canvas-> color( $self-> {backColor});
$canvas-> backColor( $self-> {fillBackColor});
$self-> {smooth} ?
$canvas-> fill_spline( $p) :
$canvas-> fillpoly( $p);
}
if ( $self-> {outline}) {
$canvas-> lineWidth( $self-> lineWidth * $width / $self-> width);
$canvas-> color( $self-> {color});
$canvas-> backColor( $self-> {outlineBackColor});
$self-> {smooth} ?
$canvas-> spline( $p) :
$canvas-> polyline( $p);
}
}
sub lineWidth
{
return $_[0]-> SUPER::lineWidth unless $#_;
my $self = shift;
$self-> SUPER::lineWidth(@_);
$self-> adjust;
}
package Prima::Canvas::Image;
use vars qw(@ISA);
@ISA = qw(Prima::CanvasObject);
sub profile_default
{
$_[0]-> SUPER::profile_default,
image => undef,
}
sub uses
{
my $i = $_[0]-> {image};
my @ret;
if ( $i) {
push @ret, 'rop';
push @ret, qw(color backColor) if
$i-> isa('Prima::DeviceBitmap') && $i-> type == dbt::Bitmap;
}
@ret;
}
sub on_paint
{
my ( $self, $canvas, $width, $height) = @_;
my $i = $self-> {image};
unless ( defined $i) {
my @save = $canvas-> get( qw(color fillPattern));
$canvas-> set(
color => cl::Gray,
fillPattern => fp::BkSlash,
);
$canvas-> bar( 0,0,$width-1,$height-1);
$canvas-> set( @save);
} else {
$canvas-> stretch_image( 0,0, $width, $height, $i);
}
}
sub image
{
return $_[0]-> {image} unless $#_;
$_[0]-> {image} = $_[1];
$_[0]-> repaint;
}
package Prima::Canvas::Text;
use vars qw(@ISA);
@ISA = qw(Prima::CanvasObject);
sub profile_default
{
$_[0]-> SUPER::profile_default,
text => '',
flags => dt::Default|dt::DrawSingleChar|dt::DrawPartial,
tab => 8,
textOpaque => 0,
}
sub uses
{
my $self = $_[0];
my @ret = qw(font color rop);
push @ret, qw(backColor textOpaque) if $self-> {textOpaque};
@ret;
}
sub on_paint
{
my ( $self, $canvas, $width, $height) = @_;
$canvas-> draw_text( $self-> {text}, 0, 0,
$width-1, $height-1, $self-> {flags}, $self-> {tab});
}
sub text
{
return $_[0]-> {text} unless $#_;
$_[0]-> {text} = $_[1];
$_[0]-> repaint;
}
sub flags
{
return $_[0]-> {flags} unless $#_;
$_[0]-> {flags} = $_[1];
$_[0]-> repaint;
}
sub tab
{
return $_[0]-> {tab} unless $#_;
$_[0]-> {tab} = $_[1];
$_[0]-> repaint;
}
package Prima::Canvas::Widget;
use vars qw(@ISA);
@ISA = qw(Prima::CanvasObject);
sub profile_default
{
$_[0]-> SUPER::profile_default,
widget => undef,
scalable => 1,
}
sub init
{
my ( $self, $defaults, $properties) = @_;
$self-> {base_size} = [0,0];
if ( !exists $properties-> {size} && !exists $properties-> {rect} &&
defined $properties-> {widget}) {
$properties-> {size} = [$properties-> {widget}-> size];
}
if ( !exists $properties-> {origin} && !exists $properties-> {rect} &&
defined $properties-> {widget}) {
$properties-> {origin} = [$properties-> {widget}-> origin];
}
}
sub on_destroy
{
return unless $_[0]-> {widget};
$_[0]-> {widget}-> destroy;
}
sub destroy
{
my $self = $_[0];
if ( $self-> {widget}) {
$self-> {widget}-> destroy;
$self-> {widget} = undef;
}
$self-> SUPER::destroy;
}
sub scalable
{
return $_[0]-> {scalable} unless $#_;
$_[0]-> {scalable} = $_[1];
}
sub instance { $_[1]-> {__PRIMA__CANVAS__OBJECT__}}
sub widget
{
return $_[0]-> {widget} unless $#_;
my ( $self, $widget) = @_;
return unless $self-> {widget} = $widget;
$widget-> {__PRIMA__CANVAS__OBJECT__} = $self;
my @sz = $widget-> size;
if ( $self-> {owner}) {
$widget-> owner( $self-> {owner});
$widget-> send_to_back;
} else {
$widget-> visible(0);
$widget-> owner( $::application);
}
$self-> {base_size} = \@sz;
$self-> on_layoutchanged;
}
sub visible
{
return $_[0]-> SUPER::visible unless $#_;
$_[0]-> SUPER::visible( $_[1]);
$_[0]-> {widget}-> visible( $_[1])
if $_[0]-> {widget} && $_[0]-> {owner};
}
sub owner
{
return $_[0]-> SUPER::owner unless $#_;
my ( $self, $owner) = @_;
$self-> SUPER::owner( $owner);
return unless $self-> {widget};
if ( $owner) {
$self-> {widget}-> owner( $owner);
$self-> {widget}-> visible( 1) if $self-> {visible};
$self-> {widget}-> send_to_back;
$self-> on_layoutchanged;
} else {
$self-> {widget}-> owner( $::application);
$self-> {widget}-> visible( 0);
}
}
sub on_size { $_[0]-> on_layoutchanged }
sub on_move { $_[0]-> on_layoutchanged }
sub on_layoutchanged
{
my $self = $_[0];
return unless $self-> {widget} && $self-> {owner};
my @r = $self-> {owner}-> object2screen( $self-> rect);
if ( $self-> {scalable}) {
$self-> {widget}-> rect(@r);
} else {
$self-> {widget}-> origin(@r[0,1]);
}
}
package main;
use Prima qw(Application StdBitmap Dialog::ColorDialog Dialog::FontDialog Buttons);
my ( $colordialog, $logo, $bitmap, $fontdialog);
$logo = Prima::StdBitmap::icon(0);
( $bitmap, undef) = $logo-> split;
$bitmap-> set( conversion => ict::None, type => im::BW);
$bitmap = $bitmap-> bitmap;
my $w = Prima::MainWindow-> create(
text => 'Canvas demo',
menuItems => [
['~Object' => [
(map { [ $_ => "~$_" => \&insert_from_menu] }
qw(Rectangle Ellipse Arc Chord Sector Image Bitmap Line Polygon Text Button InputLine)),
[],
[ '~Delete' => 'Del' , kb::Delete , \&delete]
]],
['~Edit' => [
['color' => '~Foreground color' => \&set_color],
['backColor' => '~Background color' => \&set_color],
[],
['~Line width' => [ map { [ "lw$_", $_, \&set_line_width ] } 0..7, 10, 15 ]],
['Line ~pattern' => [ map { [ "lp:linePattern=$_", $_, \&set_constant ] }
sort grep { !m/AUTOLOAD|constant|BEGIN|END/ } keys %lp:: ]],
['Line ~end' => [ map { [ "le:lineEnd=$_", $_, \&set_constant ] }
sort grep { !m/AUTOLOAD|constant|BEGIN|END/ } keys %le:: ]],
['Line ~join' => [ map { [ "lj:lineJoin=$_", $_, \&set_constant ] }
sort grep { !m/AUTOLOAD|constant|BEGIN|END/ } keys %lj:: ]],
['Fill ~pattern' => [ map { [ "fp:fillPattern=$_", $_, \&set_constant ] }
sort grep { !m/AUTOLOAD|constant|BEGIN|END/ } keys %fp:: ]],
['~Rop' => [ map { [ "rop:rop=$_", $_, \&set_constant ] }
sort grep { !m/AUTOLOAD|constant|BEGIN|END/ } keys %rop:: ]],
['Rop~2' => [ map { [ "rop:rop2=$_", $_, \&set_constant ] }
sort grep { !m/AUTOLOAD|constant|BEGIN|END/ } keys %rop:: ]],
['Fill r~ule' => [ map { [ "fm:fillMode=$_", $_, \&set_constant ] }
sort grep { !m/AUTOLOAD|constant|BEGIN|END/ } keys %fm:: ]],
[],
['fill' => 'Toggle ~fill' => \&toggle],
['outline' => 'Toggle ~outline' => \&toggle],
[],
['Arc,Chord,Sector' => [
['arc-' => 'Rotate ~right' => \&arc_rotate],
['arc+' => 'Rotate ~left' => \&arc_rotate],
['arc++' => 'E~xtend' => \&arc_rotate],
['arc--' => '~Shrink' => \&arc_rotate],
]],
['Line,Polygon' => [
['smooth1' => '~Spline' => \&smooth],
['smooth0' => '~Straigth' => \&smooth],
['rotate-' => 'Rotate ~right' => \&line_rotate],
['rotate+' => 'Rotate ~left' => \&line_rotate],
[],
['Set ~arrows' => [
map {["arrow=$_", ucfirst, \&set_arrowhead]} 'none', keys %Prima::Canvas::Line::arrowheads,
]],
['Set arrowhead ~size' => [
map {["arrow=$_", $_, \&set_arrowhead]} 1,2,3,4,5
]],
]],
['Te~xt' => [
['font' => '~Font' => \&set_font],
[],
['textOpaque1' => '~Opaque' => \&set_text_opaque],
['textOpaque0' => '~Transparent' => \&set_text_opaque],
[],
(map { [ "dt:$_:".(dt::Left|dt::Right|dt::Center), $_, \&set_text_flags ]}
qw(Left Right Center) ),
[],
(map { [ "dt:$_:".(dt::Top|dt::Bottom|dt::VCenter), $_, \&set_text_flags ]}
qw(Top Bottom VCenter)),
[],
(map { [ "dt:$_", $_, \&set_text_flags ]}
qw(DrawPartial NewLineBreak WordBreak ExpandTabs UseExternalLeading))
]],
]],
['~View' => [
['zoom+' => 'Zoom in' => '+' => '+' => \&zoom],
['zoom-' => 'Zoom out' => '-' => '-' => \&zoom],
['zoom0' => 'Zoom 100%' => 'Ctrl+1' => '^1' => \&zoom],
[],
['Align ~horizontally' => [
map { [ "alignment=$_", $_, \&align ]} qw(Left Center Right)
]],
['Align ~vertically' => [
map { [ "valignment=$_", $_, \&align ]} qw(Top Center Bottom)
]],
]],
],
);
my $c = $w-> insert( 'Prima::CanvasEdit' =>
origin => [0,0],
size => [$w-> size],
growMode => gm::Client,
paneSize => [ 500, 500],
hScroll => 1,
vScroll => 1,
name => 'Canvas',
buffered => 1,
alignment => ta::Center,
valignment => ta::Middle,
);
my $widget_popup =
[
[ '~Move' => sub {
my ( $self, $obj, $owner);
return unless $obj = Prima::Canvas::Widget-> instance( $self = $_[0]);
return unless $owner = $obj-> owner;
my @pp = $owner-> object2screen(
$obj-> left + $obj-> width / 2,
$obj-> bottom + $obj-> height / 2);
$owner-> pointerPos( @pp);
$owner-> mouse_down( mb::Left, 0, @pp, 1);
}],
[ '~Delete' => sub {
return unless $_ = Prima::Canvas::Widget-> instance( $_[0]);
$_-> destroy;
}],
];
sub insert
{
my ( $self, $obj, %profile) = @_;
$profile{image} = $logo if $obj eq 'Image';
$profile{image} = $bitmap, $obj = 'Image' if $obj eq 'Bitmap';
if ( $obj eq 'Line') {
$profile{points} = [ 10,10,10,50,50,40,100,0,50,60,90,90];
$profile{shift} = [ 50,50];
$profile{arrows} = [ 'feather:2','feather:-2'];
$profile{size} = [ 200,200];
$profile{anchor} = [ 50,50];
$profile{lineEnd} = le::Flat;
$profile{lineWidth} = 3,
$profile{smooth} = 1;
}
if ( $obj eq 'Polygon') {
$profile{points} = [ 20,0,50,100,80,0,0,65,100,65];
$profile{anchor} = [50,50];
}
if ( $obj eq 'Button') {
$profile{widget} = Prima::Button-> create( owner => $c);
$obj = 'Widget';
}
if ( $obj eq 'InputLine') {
$profile{widget} = Prima::InputLine-> create( owner => $c);
$profile{scalable} = 0;
$obj = 'Widget';
}
if ( $obj eq 'Widget') {
$profile{widget}-> popupItems( $widget_popup);
}
$profile{text} = "use Prima qw(Application);\nMainWindow-> create();\nrun Prima;"
if $obj eq 'Text';
$c-> focused_object( $c-> insert_object( "Prima::Canvas::$obj", %profile));
}
sub insert_from_menu
{
my ( $self, $obj ) = @_;
insert($self, $obj);
}
sub delete
{
my $obj;
return unless $obj = $_[0]-> Canvas-> focused_object;
$_[0]-> Canvas-> delete_object( $obj);
}
sub set_color
{
my ( $self, $property) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
$colordialog = Prima::Dialog::ColorDialog-> create unless $colordialog;
$colordialog-> value( $obj-> $property());
$obj-> $property( $colordialog-> value) if $colordialog-> execute != mb::Cancel;
}
sub set_font
{
my ( $self, $property) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
$fontdialog = Prima::Dialog::FontDialog-> create unless $fontdialog;
$fontdialog-> logFont( $obj-> font);
$obj-> font( $fontdialog-> logFont) if $fontdialog-> execute != mb::Cancel;
}
sub set_line_width
{
my ( $self, $lw) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
$lw =~ s/^lw//;
$obj-> lineWidth( $lw);
}
sub set_constant
{
my ( $self, $cc) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
return unless $cc =~ /^(\w+)\:(\w+)\=(.*)$/;
$obj-> $2( eval "$1::$3");
}
sub toggle
{
my ( $self, $property) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
return unless $obj-> can( $property);
$obj-> $property( !$obj-> $property());
}
sub zoom
{
my ( $self, $zoom) = @_;
$zoom =~ s/^zoom//;
my $c = $self-> Canvas;
if ( $zoom eq '+') {
$c-> zoom( $c-> zoom * 1.1);
} elsif ( $zoom eq '-') {
$c-> zoom( $c-> zoom * 0.9);
} elsif ( $zoom eq '0') {
$c-> zoom( 1);
}
}
sub align
{
my ( $self, $align) = @_;
my $c = $self-> Canvas;
$align =~ m/([^\=]+)\=(.*)$/;
$c-> $1( eval "ta::$2");
}
sub arc_rotate
{
my ( $self, $arc) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
return unless $obj-> isa('Prima::Canvas::Arc') || $obj-> isa('Prima::Canvas::FilledArc');
$arc =~ s/^arc//;
if ( $arc eq '+') {
$obj-> start( $obj-> start + 22.5);
$obj-> end( $obj-> end + 22.5);
} elsif ( $arc eq '-') {
$obj-> start( $obj-> start - 22.5);
$obj-> end( $obj-> end - 22.5);
} elsif ( $arc eq '++') {
$obj-> end( $obj-> end + 22.5);
} elsif ( $arc eq '--') {
$obj-> end( $obj-> end - 22.5);
}
}
sub line_rotate
{
my ( $self, $line) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
return unless $obj-> isa('Prima::Canvas::line_properties');
$line =~ s/^rotate//;
if ( $line eq '+') {
$obj-> rotate( $obj-> rotate + 10);
} elsif ( $line eq '-') {
$obj-> rotate( $obj-> rotate - 10);
}
}
sub set_arrowhead
{
my ( $self, $arrow) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
return unless $obj-> isa('Prima::Canvas::Line');
$arrow =~ s/^arrow\=//;
if ( $arrow =~ /^\d+$/) {
for ( $obj-> arrows) {
$_-> aspect( $arrow, $arrow) if $_;
}
$obj-> adjust;
$obj-> repaint;
} else {
$arrow = undef if $arrow eq 'none';
$obj-> arrows( $arrow, $arrow);
}
}
sub smooth
{
my ( $self, $smooth) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
return unless $obj-> can('smooth');
$smooth =~ s/^smooth//;
$obj-> smooth( $smooth);
}
sub set_text_opaque
{
my ( $self, $o) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
$o =~ s/^textOpaque//;
$obj-> textOpaque( $o);
}
sub set_text_flags
{
my ( $self, $flags) = @_;
my $obj;
return unless $obj = $self-> Canvas-> focused_object;
return unless $obj-> isa('Prima::Canvas::Text');
my @f = split(':', $flags);
$flags = $obj-> flags;
$f[1] = eval "dt::$f[1]";
if ( 2 == @f) {
$flags = (( $flags & $f[1]) ?
$flags & ~$f[1] :
$flags | $f[1]
);
} elsif ( 3 == @f) {
$flags &= ~($f[2]+0);
$flags |= $f[1];
}
$obj-> flags( $flags);
}
insert( $c, 'Button', origin => [ 0, 0]);
insert( $c, 'Rectangle', linePattern => lp::DotDot, lineWidth => 10, origin => [ 50, 50]);
insert( $c, 'Line', origin => [ 200, 200]);
insert( $c, 'Polygon', origin => [ 150, 150]);
insert( $c, 'Bitmap', origin => [ 350, 350], backColor => cl::LightGreen, color => cl::Green);
run Prima;
|