Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Polygons in Tk

by batkins (Chaplain)
on Jan 20, 2004 at 13:53 UTC ( [id://322584]=perlquestion: print w/replies, xml ) Need Help??

batkins has asked for the wisdom of the Perl Monks concerning the following question:

Is there any way to render polygons on the fly in Tk? I know that Tk::Canvas lets you create polygon objects, but I'm looking for a way to render polygons quickly. Something like $canvas->fillPolygon(@vertices). The vertices and colors of the polygons will change often, so I think the overhead of createPolygon is too much.
Are you sure it was a book? Are you sure it wasn't.....nothing?

Replies are listed 'Best First'.
Re: Polygons in Tk
by PodMaster (Abbot) on Jan 20, 2004 at 14:13 UTC
    There is apparently an OpenGL Tk widget (according to google), but no binding for perl (you could try binding it yourself). Prima was actually designed for this ... "PRIMA is a general purpose extensible graphical user interface toolkit with a rich set of standard widgets and an emphasis on 2D image processing tasks."

    MJD says "you can't just make shit up and expect the computer to know what you mean, retardo!"
    I run a Win32 PPM repository for perl 5.6.x and 5.8.x -- I take requests (README).
    ** The third rule of perl club is a statement of fact: pod is sexy.

Re: Polygons in Tk
by zentara (Archbishop) on Jan 20, 2004 at 15:23 UTC
    I think Tk::Zinc is far superior to the regular canvas, you might want to look at it's easy method for creating curves. A polygon is a curve in Zinc.

    Here is a script I had laying around which uses the regular canvas, and some vector methods for generating the polygon.

    #!/usr/bin/perl -w ##################################################### ### Copyright (c) 2002 Russell B Cecala. All rights ### reserved. This program is free software; you can ### redistribute it and/or modify it under the same ### terms as Perl itself. ##################################################### use strict; use Data::Dumper; use Math::Round qw( nearest_floor nearest_ceil ); use Tk; use Tk::Canvas; my $width = 320; my $height = 200; #adjust these vectors for shape my $A = new Vector2D( 90 + 30, $height - 70 ); my $B = new Vector2D( 80 + 170, $height - 50 ); my $C = new Vector2D( 180 + 30, $height - 90 ); my $D = new Vector2D( 80 + 180, $height - 150 ); my $E = new Vector2D( 50 + 90, $height - 110 ); my $F = new Vector2D( 68 + 70, $height - 130 ); my @AB = [ $A, $B ]; my @BC = [ $B, $C ]; my @CD = [ $C, $D ]; my @DE = [ $D, $E ]; my @EF = [ $E, $F ]; my @FA = [ $F, $A ]; my @edges = ( @AB, @BC, @CD, @DE, @EF, @FA ); my $top = MainWindow->new(); my $can = $top->Canvas( -width => $width, -height=> $height, -backgrou +nd=>'white' )->pack(); my $polygon = new Polygon( \@edges, $can, 126 ); $polygon->fill(); MainLoop; BEGIN { { package Polygon; use strict; use Exporter; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); use Data::Dumper; use Math::Round qw( nearest_floor nearest_ceil ); use Tk; use Tk::Canvas; $VERSION = 1.00; @ISA = qw(Exporter); @EXPORT = (); sub new { my ($pkg, $polygon, $canvas, $color) = @_; my $highestY = getHighestY($polygon); bless { polygon => $polygon, # ref to array of pairs of Vector2D ET => undef, # edge table highestY => $highestY, can => $canvas, #Tk canvas color => $color }, $pkg; } sub dumpET { my $pkg = shift; my $et = $pkg->{ET}; my $highestY = $pkg->{highestY}; for my $i (0..$highestY-1) { if ( @{$et}[$i] ) { print "et[$i] = "; for my $list ( @{$et}[$i] ) { for my $r ( @{$list} ) { print "{" . %{$r}->{Ymax} . "|" . %{$r}->{Xbot} . "|" . %{$r}->{invSlo +pe} . "}" ; } } print "\n"; } else { print "et[$i] = NULL\n"; } } } sub buildET { my $pkg = shift; # each entry in the Edge Table (ET) contains the Ymax coordinate of th +e edge, # the x cooridnate of the bottom endpoint Xbot and the x increment # used in the stepping from one scan lime to the next 1/m for my $edge (@{$pkg->{polygon}}) { my $y = ( @{$edge}->[0]->gety() < @{$edge}->[1]->gety() ) ? @{$edg +e}->[0]->gety() : @{$edge}->[1]->gety() ; my $Ymax = ( @{$edge}->[0]->gety() >= @{$edge}->[1]->gety() ) ? @{$edg +e}->[0]->gety() : @{$edge}->[1]->gety() ; my $Xbot = ( @{$edge}->[0]->gety() < @{$edge}->[1]->gety() ) ? @{$edg +e}->[0]->getx() : @{$edge}->[1]->getx() ; my $invSlope = &calcOneOverSlope($edge); my $rec = { Ymax => $Ymax, Xbot => $Xbot, invSlope => $invSlope, }; push( @{$pkg->{ET}[$y]}, $rec ); } my $highestY = $pkg->{highestY}; for my $i (0..$highestY-1) { if ( $pkg->{ET}[$i] ) { return $i; } } } ################################################# ### ### fill is based on the algorthim described ### in "Computer Graphics Principles and ### Practice" Foley, van Dam, Feiner, and ### Hughes 2nd edition (pg 92-99) ### ################################################# sub fill { my $pkg = shift; my $color = $pkg->{color}; my $y = $pkg->buildET(); my @ET = @{$pkg->{ET}}; my @AET; # Active Edge Table do { # print "================== doing scan line $y ================\n"; # Move from ET bucket y to the AET those edges whose Ymin = y if ( $ET[$y] ) { while( @{$ET[$y]} ) { my $e = pop( @{$ET[$y]} ); push( @AET, $e ); } $ET[$y] = undef; } # then sort AET on x @AET = sort{ %{$a}->{Xbot} <=> %{$b}->{Xbot} } @AET; my $last; for ( my $i=0; $i<$#AET+1; ) { my $X1; my $X2; my $x1 = $AET[$i++]; my $x2 = $AET[$i++]; if ( $x2 ) { $last = $x2; $X1 = nearest_ceil(1,%{$x1}->{Xbot}); $X2 = nearest_floor(1,%{$x2}->{Xbot}); } else { $X1 = nearest_ceil(1,%{$last}->{Xbot}); $X2 = nearest_floor(1,%{$x1}->{Xbot}); } for my $x ( $X1..$X2 ) { $pkg->setPixel( $x, $y, $color ); } } my @AET_copy; # = @AET; while( @AET ) { my $e = pop( @AET ); if ( %{$e}->{Ymax} != $y ) { push( @AET_copy, $e ); } } $y++; @AET = @AET_copy; for ( my $i=0; $i<$#AET+1; $i++ ) { if ( %{$AET[$i]}->{invSlope} != 0 ) { %{$AET[$i]}->{Xbot} += %{$AET[$i]}->{invSlope}; } } } while( $#AET >= 0 and $#ET >= 0 ); } sub calcOneOverSlope { my $edge = shift; my $y = @{$edge}->[0]->gety()-@{$edge}->[1]->gety(); my $x = @{$edge}->[0]->getx()-@{$edge}->[1]->getx(); if ( $y == 0 ) { return undef; } return $x/$y; } sub getHighestY { my $edges = shift; my $edge = @{$edges}[0]; my $vector = @{$edge}[0]; my $highest = $vector->gety(); for my $edge (@{$edges}) { for my $vector (@{$edge}) { my $y = $vector->gety(); if ( $y > $highest ) { $highest = $y; } } } return $highest; } sub setPixel { my ( $pkg, $X, $Y, $color ) = @_; my $rgb = sprintf "#%03x", $color; $pkg->{can}->create ( 'rectangle', $X, $Y, $X+1, $Y+1, -fill => $rgb, -outline => $rgb ); } 1; } { package Vector2D; use strict; use Exporter; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); use overload "-" => \&minus, "+" => \&plus, "*" => \&mult, "bool" => \&bool, "==" => \&equal; $VERSION = 1.00; @ISA = qw(Exporter); @EXPORT = (); sub new { my ($pkg,$x,$y) = @_; bless { _x => $x, _y => $y }, $pkg; } sub getx { my $obj = shift; return $obj->{_x}; } sub gety { my $obj = shift; return $obj->{_y}; } sub setx { my $obj = shift; my $v = shift; $obj->{_x} = $v; } sub sety { my $obj = shift; my $v = shift; $obj->{_y} = $v; } sub getxy { my $obj = shift; my @xy = ( $obj->getx(), $obj->gety() ); return @xy; } sub plus { my $u = shift; my $v = shift; return new Vector2D ( $u->getx() + $v->getx(), $u->gety() + $v->gety() ); } sub minus { my $u = shift; my $v = shift; return new Vector2D ( $u->getx() - $v->getx(), $u->gety() - $v->gety() ); } sub mult { my $v = shift; my $c = shift; return new Vector2D ( $c * $v->getx(), $c * $v->gety() ); } sub bool { return defined( shift ); } sub equal { my $u = shift; my $v = shift; return ( $u->getx() == $v->getx() ) && ( $u->gety() == $v->gety() ); } sub incr { my $u = shift; my $v = shift; $u->{_x} += $v->{_x}; $u->{_y} += $v->{_y}; return $u; } sub decr { my $u = shift; my $v = shift; $u->{_x} -= $v->{_x}; $u->{_y} -= $v->{_y}; return $u; } sub scale { my $v = shift; my $c = shift; $v->{_x} *= $c; $v->{_y} *= $c; return $v; } sub rotate { my $P = shift; #vector my $C = shift; #vector my $cosphi = shift; my $sinphi = shift; my $dx = $P->{_x} - $C->{_x}; my $dy = $P->{_y} - $C->{_y}; return new Vector2D ( $C->{_x} + $dx * $cosphi - $dy * $sinphi, $C->{_y} + $dx * $sinphi + $dy * $cosphi ); } sub print { my $v = shift; #vector print "( " . $v->getx() . ", " . $v->gety() . ")\n"; } 1; } }

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://322584]
Approved by jdtoronto
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others pondering the Monastery: (4)
As of 2024-03-29 00:51 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found