1=pod 2 3=head1 NAME 4 5examples/eyes.pl - An eyes program clone 6 7=head1 FEATURES 8 9A well-known eyes written in Prima toolkit. 10Demostrates the usage of a shape-extension and a 11determination of its support on a system. 12 13Note the menu hide feature - it's activation (^M) 14tests a correct implementation of a Prima 15shape-extension interface. 16 17=cut 18 19use strict; 20use warnings; 21use Prima; 22use Prima::Application name => 'Eyes'; 23 24 25my $eye = 0.45; 26my $ball = 0.06; 27 28my $revcolors = 0; 29my $canshape = $::application-> get_system_value( sv::ShapeExtension); 30 31sub reshape 32{ 33 my $x = $_[0]; 34 my @sz = $x-> size; 35 my $nope = $sz[0] < 5 || $sz[1] < 5; 36 for (0,1) { 37 $sz[$_] = 5 if $sz[$_] < 5; 38 } 39 my $i = Prima::Image-> create( 40 width => $sz[0], 41 height => $sz[1], 42 type => im::BW, 43 ); 44 $i-> begin_paint; 45 $i-> color( cl::White); 46 $i-> backColor( cl::Black); 47 $i-> clear; 48 my $minSz = ( $sz[0] < $sz[1]) ? $sz[0] : $sz[1]; 49 my @eye = ( $sz[0] * $eye, $sz[1] * $eye * 2); 50 $i-> lineWidth(( $minSz < 220) ? $minSz / 20 : 11); 51 $i-> ellipse( $sz[0] * 0.25, $sz[1]/2, @eye); 52 $i-> fill_ellipse( $sz[0]*0.25, $sz[1]/2, @eye); 53 $i-> ellipse( $sz[0]*0.75, $sz[1]/2, @eye); 54 $i-> fill_ellipse( $sz[0]*0.75, $sz[1]/2, @eye); 55 $i-> end_paint; 56 $x-> shape( $i) unless $nope; 57 return $i; 58} 59 60my $m; 61 62my $x = Prima::MainWindow-> create( 63 visible => 0, 64 buffered => 1, 65 color => cl::Black, 66 backColor => cl::White, 67 menuItems => [ 68 ['~Options' => [ 69 ["~Reverse colors" => sub { 70 my ( $self, $mit) = @_; 71 $revcolors = $revcolors ? 0 : 1; 72 $self-> menu-> text( $mit, 73 $revcolors ? "~Normal colors" : "~Reverse colors"); 74 $self-> color( $revcolors ? cl::White : cl::Black); 75 $self-> backColor( $revcolors ? cl::Black : cl::White); 76 }], 77 ['~Remove menu' => 'Ctrl+M' => '^M' => sub { 78 if ( $_[0]-> menu) { 79 $m = $_[0]-> menu; 80 $_[0]-> menu-> selected(0); 81 } else { 82 $m-> selected(1); 83 } 84 }], 85 [], 86 ["E~xit" => 'Alt+X' => '@X' => sub { $::application-> close }], 87 ]], 88 ], 89 size => [ 200, 300], 90 name => 'Eyes', 91 onSize => sub { 92 reshape( $_[0]) if $canshape; 93 }, 94 onPaint => sub { 95 my ( $self, $canvas) = @_; 96 my @sz = $self-> size; 97 $canvas-> clear; 98 my $minSz = ( $sz[0] < $sz[1]) ? $sz[0] : $sz[1]; 99 $canvas-> lineWidth(( $minSz < 220) ? $minSz / 20 : 11); 100 my @cc = ( $sz[0]* 0.25, $sz[1]/2); 101 my @eye = ( $sz[0] * $eye, $sz[1] * $eye * 2); 102 my @pp = $self-> pointerPos; 103 for ( 0..1) { 104 $canvas-> translate( @cc); 105 $canvas-> ellipse( 0, 0, @eye); 106 my @dd = ( $pp[0] - $cc[0], $pp[1] - $cc[1]); 107 my $angle = atan2( $dd[1], $dd[0]); 108 my ( $sin, $cos) = ( sin($angle), cos( $angle)); 109 my $h = sqrt( 110 ($eye[1]*$cos) * ($eye[1]*$cos) + 111 ($eye[0]*$sin) * ($eye[0]*$sin) 112 ); 113 my @da = ( $eye[0] * $eye[1] * $cos / $h, $eye[0] * $eye[1] * $sin / $h); 114 my $dp = sqrt( $dd[0] * $dd[0] + $dd[1] * $dd[1]); 115 my $db = sqrt( $da[0] * $da[0] + $da[1] * $da[1]) * 0.36; 116 my @e = ( $db < $dp) ? ( $db * $cos, $db * $sin) : @dd; 117 $canvas-> fill_ellipse( @e, $sz[0]* $ball, $sz[1]* $ball * 2); 118 $cc[0] += $sz[0] / 2; 119 } 120 }, 121); 122 123$x-> icon( reshape( $x)); 124 125my @pp = $x-> pointerPos; 126 127$x-> insert( Timer => 128 timeout => 100, 129 onTick => sub { 130 my @pxp = $x-> pointerPos; 131 return if $pxp[0] == $pp[0] && $pxp[1] == $pp[1]; 132 $x-> repaint; 133 @pp = @pxp; 134 })-> start; 135$x-> show; 136$x-> select; 137 138run Prima; 139