The Labs.Com Issue_09_Tk

TPJ: Issue_09_Tk

This is a collection of programs published by The Perl Journal. You can download all source-code also from TPJ: Programs.

1. Mow.pm
2. circle
3. nz-tr1
4. nz-tr2
5. rotate
6. zero-tr1
7. zero-tr2
8. arcstyle
9. capstyle
10. join_style
11. joinstyle
12. spline
13. More Samples on Tk

Download Mow.pm

# Mow.pm - mowing module.

#

# Stephen O. Lidie@Lehigh.EDU, 97/09/15.

package Mow;

use 5.004;

use Exporter;

@ISA = qw(Exporter);

@EXPORT = qw/$CHLOROPHYLL $COLOR $CUT $D2R $PPF $SIDE $TURN/;

$CHLOROPHYLL = '#8395ffff0000';        # rye-grass-green, maybe

$COLOR = 0xffff;                # initial line color, maximum saturati\

on

$CUT = (38 / 12);                # cut width in feet

$D2R = 3.14159265 / 180.0;        # map degrees to radians

$PPF = 2;                        # pixels/foot

$SIDE = 100;                        # length of side of square mowing \

area, in feet

$TURN = (27 / 12);                # turn radius in feet

1;

Issue_09_Tk 2. circle

Download circle

#!/usr/local/bin/perl -w

#

# Mow in circles.

#

# Stephen.O.Lidie@Lehigh.EDU, 97/09/14.

use English;

use Mow;

use Tk;

use subs qw/init mow/;

use strict;

my $canvas = init;

mow $canvas, (0, 0), ($SIDE, $SIDE);

MainLoop;

sub init {

my $mw = MainWindow->new;

my $mow_side = $SIDE * $PPF;

my $canvas = $mw->Canvas(-width => $mow_side, -height => \

$mow_side,

-background => $CHLOROPHYLL)->grid;

$mw->waitVisibility;

return $canvas;

} # end init

sub mow {

# Recursively mow until done.

my($canvas, $x1, $y1, $x2, $y2) = @ARG;

return if $x1 >= $x2 or $y1 >= $y2;

my $color = sprintf("#ffff%04x%04x", $COLOR, $COLOR);

$COLOR -= 0x0800;

$canvas->createOval($x1 * $PPF, $y1 * $PPF,        $x2 * $PPF, \

$y2 * $PPF,

-width => $CUT * $PPF + 0.5, -outline =>\

$color);

$canvas->idletasks;

$canvas->after(250);

mow $canvas, $x1+$CUT, $y1+$CUT, $x2-$CUT, $y2-$CUT;

} # end mow

Issue_09_Tk 3. nz-tr1

Download nz-tr1

#!/usr/local/bin/perl -w

#

# Mow with precision and NZ turning radius.

#

# Stephen.O.Lidie@Lehigh.EDU, 97/12/24.

use English;

use Mow;

use Tk;

use subs qw/c init mow rotate_items/;

use vars qw/@ARC @LINE $WIDTH_TOGGLE/;

use strict;

my $canvas = init;

mow $canvas, (0, 0), ($SIDE, $SIDE);

MainLoop;

sub c {

$_[0] * $PPF;                # scale and translate user units to c\

anvas

}

sub init {

@LINE = ($SIDE, 0);                # initial straight line mowing \

path

@ARC = ($TURN, $TURN);        # generic turning radius arc

$WIDTH_TOGGLE = -1;                # -1 or 1

my $mw = MainWindow->new;

$mw->title('NZ Turning Radius');

my $mow_side = c($SIDE);        # side of mowing area in pixels

my $canvas = $mw->Canvas(-width => $mow_side, -height => \

$mow_side,

-background => $CHLOROPHYLL)->grid;

$canvas->CanvasBind('<Double-1>' => sub {

$WIDTH_TOGGLE = 0 - $WIDTH_TOGGLE;

my $width = $WIDTH_TOGGLE == 1 ? 1 : c($CUT)+0.5;

$canvas->itemconfigure('path',  -width => $width);});

my $zf = $mw->Frame->grid;

my $origin = c($SIDE / 2);

my $zi = $zf->Button(qw/-text ZoomIn -command/ =>

[$canvas => 'scale', 'path', $origin, $ori\

gin, 2.0, 2.0]);

my $zo = $zf->Button(qw/-text ZoomOut -command/ =>

[$canvas => 'scale', 'path', $origin, $ori\

gin, 0.5, 0.5]);

$zi->grid(qw/-row 0 -column 0/);

$zo->grid(qw/-row 0 -column 1/);

$mw->waitVisibility;

return $canvas;

} # end init

sub mow {

# Recursively mow until done.

my($canvas, $x1, $y1, $x2, $y2) =  @ARG;

return if $x1 >= $x2 or $y1 >= $y2;

my $color = sprintf("#ffff%04x%04x", $COLOR, $COLOR);

$COLOR -= 0x0800;

rotate_items $canvas,   0, $x1, $y1, $color;

rotate_items $canvas,  90, $x2, $y1, $color;

rotate_items $canvas, 180, $x2, $y2, $color;

rotate_items $canvas, 270, $x1, $y2, $color;

$canvas->idletasks;

$canvas->after(250);

mow $canvas, $x1+$CUT, $y1+$CUT, $x2-$CUT, $y2-$CUT;

} # end mow

sub rotate_items {

# Rotate the generic straight-line mowing path and turning arc

# around (0,0) and translate to the mowing area.

my($canvas, $angle, $x1, $y1, $color) = @ARG;

my $theta = $angle * $D2R;

my(%quadrant) = (0 => [1,0], 90 => [0,1], 180 => [-1, 0],\

270 => [0, -1]);

my($x2, $y2) = @LINE[0,1];

$LINE[0] -= 2 * $CUT if $angle == 270;

my $nx2 = $x2 * cos($theta) + $y2 * sin($theta);

my $ny2 = $x2 * sin($theta) - $y2 * cos($theta);

my($dx1, $dy1) = map $ARG * $TURN, @{$quadrant{$angle}};

my(@start) = ($x1 + $dx1, $y1 + $dy1);

my(@end) =   ($x1 + $nx2, $y1 + $ny2);

$canvas->createLine(c($start[0]), c($start[1]), c($end[0]), c($\

end[1]),

-fill => $color, -width => c($CUT)+0.5,

-capstyle => 'round', -tags => 'path');

($x2, $y2) = @ARC[0,1];

$nx2 = $x2 * cos($theta) - $y2 * sin($theta);

$ny2 = $x2 * sin($theta) + $y2 * cos($theta);

$canvas->createArc(c($end[0]), c($end[1]), c($end[0]+$nx2), c($\

end[1]+$ny2),

-start => 270-20-$angle, -extent => 180+4\

0,

-style => 'arc', -outline => $color,

-width => c($CUT)+0.5, -tags => 'path');

} # end rotate_items

Issue_09_Tk 4. nz-tr2

Download nz-tr2

#!/usr/local/bin/perl -w

#

# Mow with uncertainty and NZ turning radius.

#

# Stephen.O.Lidie@Lehigh.EDU, 98/01/08.

use English;

use Mow;

use Tk;

use subs qw/c init mow paint_x rotate_items/;

use vars qw/$ADD_X @ARC @LINE $WIDTH_TOGGLE/;

use strict;

my $canvas = init;

mow $canvas, (0, 0), ($SIDE, $SIDE);

paint_x $canvas if $ADD_X;

MainLoop;

sub c {

$_[0] * $PPF;                # scale and translate user units to c\

anvas

}

sub init {

$ADD_X = 1;                        # paint an X to cut "sloppy gra\

ss"

@LINE = ($SIDE, 0);                # initial straight line mowing \

path

@ARC = ($TURN, $TURN + $CUT); # generic turning radius arc

$WIDTH_TOGGLE = -1;                # -1 or 1

my $mw = MainWindow->new;

$mw->title('NZ Turning Radius');

my $mow_side = c($SIDE);        # side of mowing area in pixels

my $canvas = $mw->Canvas(-width => $mow_side, -height => \

$mow_side,

-background => $CHLOROPHYLL)->grid;

$canvas->CanvasBind('<Double-1>' => sub {

$WIDTH_TOGGLE = 0 - $WIDTH_TOGGLE;

my $width = $WIDTH_TOGGLE == 1 ? 1 : c($CUT)+0.5;

$canvas->itemconfigure('path',  -width => $width);});

my $zf = $mw->Frame->grid;

my $origin = c($SIDE / 2);

my $zi = $zf->Button(qw/-text ZoomIn -command/ =>

[$canvas => 'scale', 'path', $origin, $ori\

gin, 2.0, 2.0]);

my $zo = $zf->Button(qw/-text ZoomOut -command/ =>

[$canvas => 'scale', 'path', $origin, $ori\

gin, 0.5, 0.5]);

$zi->grid(qw/-row 0 -column 0/);

$zo->grid(qw/-row 0 -column 1/);

$mw->waitVisibility;

return $canvas;

} # end init

sub mow {

# Recursively mow until done.

my($canvas, $x1, $y1, $x2, $y2) =  @ARG;

return if $x1 >= $x2 or $y1 >= $y2;

my $color = sprintf("#ffff%04x%04x", $COLOR, $COLOR);

$COLOR -= 0x0800;

rotate_items $canvas,   0, $x1, $y1, $color;

rotate_items $canvas,  90, $x2, $y1, $color;

rotate_items $canvas, 180, $x2, $y2, $color;

rotate_items $canvas, 270, $x1, $y2, $color;

$canvas->idletasks;

$canvas->after(250);

mow $canvas, $x1+$CUT, $y1+$CUT, $x2-$CUT, $y2-$CUT;

} # end mow

sub paint_x {

# Cut all remaining "sloppy" grass.

my($canvas) = @ARG;

$canvas->createLine(0, 0, c($SIDE), c($SIDE), -width => c(2 \

* $CUT)+0.5,

-fill => 'yellow');

$canvas->createLine(c($SIDE), 0, 0, c($SIDE), -width => c(2 \

* $CUT)+0.5,

-fill => 'yellow');

} # end paint_x

sub rotate_items {

# Rotate the generic straight-line mowing path and turning arc

# around (0,0) and translate to the mowing area.

my($canvas, $angle, $x1, $y1, $color) = @ARG;

my $theta = $angle * $D2R;

my(%quadrant) = (0 => [1,0], 90 => [0,1], 180 => [-1, 0],\

270 => [0, -1]);

my($x2, $y2) = @LINE[0,1];

$LINE[0] -= 2 * $CUT if $angle == 270;

my $nx2 = $x2 * cos($theta) + $y2 * sin($theta);

my $ny2 = $x2 * sin($theta) - $y2 * cos($theta);

my($dx1, $dy1) = map $ARG * ($TURN + $CUT), @{$quadrant{$angle}};

my(@start) = ($x1 + $dx1, $y1 + $dy1);

my(@end) =   ($x1 + $nx2, $y1 + $ny2);

$canvas->createLine(c($start[0]), c($start[1]), c($end[0]), c($\

end[1]),

-fill => $color, -width => c($CUT)+0.5,

-capstyle => 'round', -tags => 'path');

($x2, $y2) = @ARC[0,1];

$nx2 = $x2 * cos($theta) - $y2 * sin($theta);

$ny2 = $x2 * sin($theta) + $y2 * cos($theta);

$canvas->createArc(c($end[0]), c($end[1]), c($end[0]+$nx2), c($\

end[1]+$ny2),

-start => 270-40-$angle, -extent => 180+6\

0,

-style => 'arc', -outline => $color,

-width => c($CUT)+0.5, -tags => 'path');

} # end rotate_items

Issue_09_Tk 5. rotate

Download rotate

#!/usr/local/bin/perl -w

#

# Rotate a rectangle clockwise (due to Cartessian/Tk coordinate mappin\

g) about

# an arbitrary point by translating to (0, 0), rotating, and then tran\

slating

# back.  This rectangle can define the bounding box for a canvas arc i\

tem type.

#

# Stephen.O.Lidie@Lehigh.EDU, 97/12/24.

use English;

use Mow;

use Tk;

use subs qw/rotate/;

use strict;

my $mw = MainWindow->new;

my $canvas = $mw->Canvas(-width => 130, -height => 130)->g\

rid;

$mw->waitVisibility;

my $origin = 65;                # origin of canvas

my($x2, $y2) = (20, 40);        # endpoint of line segment

rotate $canvas,   0, $x2, $y2, 'black';

rotate $canvas,  90, $x2, $y2, 'red';

rotate $canvas, 180, $x2, $y2, 'green';

rotate $canvas, 270, $x2, $y2, 'blue';

MainLoop;

sub rotate {

my($canvas, $theta, $x2, $y2, $color) = @ARG;

$theta *= $D2R;                # degrees to radians

my $nx2 = $x2 * cos($theta) - $y2 * sin($theta);

my $ny2 = $x2 * sin($theta) + $y2 * cos($theta);

$canvas->createLine     (0+$origin, 0+$origin, $nx2+$origin, $n\

y2+$origin,

-fill => $color);

$canvas->createRectangle(0+$origin, 0+$origin, $nx2+$origin, $n\

y2+$origin,

-outline => $color);

my $coords = sprintf("(%d,%d)", int($nx2), int($ny2));

$canvas->createText     ($nx2+$origin, $ny2+$origin, -text =>\

; $coords,

-font => 'fixed');

$canvas->idletasks;

$canvas->after(250);

} # end rotate

Issue_09_Tk 6. zero-tr1

Download zero-tr1

#!/usr/local/bin/perl -w

#

# Mow with zero turning radius.

#

# Stephen.O.Lidie@Lehigh.EDU, 97/09/14.

use English;

use Mow;

use Tk;

use subs qw/init mow/;

use strict;

my $canvas = init;

mow $canvas, (0, 0), ($SIDE, $SIDE);

MainLoop;

sub init {

my $mw = MainWindow->new;

my $canvas = $mw->Canvas(-width => $SIDE, -height => $SID\

E,

-background => $CHLOROPHYLL)->grid;

$mw->waitVisibility;

return $canvas;

} # end init

sub mow {

# Recursively mow until done.

my($canvas, $x1, $y1, $x2, $y2) = @ARG;

return if $x1 >= $x2 or $y1 >= $y2;

$canvas->createLine($x1, $y1, $x2, $y1,

$x2, $y2,

$x1, $y2,

$x1, $y1);

$canvas->idletasks;

$canvas->after(250);

mow $canvas, $x1+$CUT, $y1+$CUT, $x2-$CUT, $y2-$CUT;

} # end mow

Issue_09_Tk 7. zero-tr2

Download zero-tr2

#!/usr/local/bin/perl -w

#

# Mow with zero turning radius.

#

# Stephen.O.Lidie@Lehigh.EDU, 97/09/14.

use English;

use Mow;

use Tk;

use subs qw/init mow/;

use strict;

my $canvas = init;

mow $canvas, (0, 0), ($SIDE, $SIDE);

MainLoop;

sub init {

my $mw = MainWindow->new;

my $mow_side = $SIDE * $PPF;

my $canvas = $mw->Canvas(-width => $mow_side, -height => \

$mow_side,

-background => $CHLOROPHYLL)->grid;

$mw->waitVisibility;

return $canvas;

} # end init

sub mow {

# Recursively mow until done.

my($canvas, $x1, $y1, $x2, $y2) = @ARG;

return if $x1 >= $x2 or $y1 >= $y2;

my $color = sprintf("#ffff%04x%04x", $COLOR, $COLOR);

$COLOR -= 0x0800;

$canvas->createLine($x1 * $PPF, $y1 * $PPF,        $x2 * $PPF, \

$y1 * $PPF,

$x2 * $PPF, $y2 * $PPF,

$x1 * $PPF, $y2 * $PPF,

$x1 * $PPF, $y1 * $PPF,

-width => $CUT * $PPF + 0.5, -fill => $c\

olor,

-joinstyle => 'miter');

$canvas->idletasks;

$canvas->after(250);

mow $canvas, $x1+$CUT, $y1+$CUT, $x2-$CUT, $y2-$CUT;

} # end mow

Issue_09_Tk 8. arcstyle

Download arcstyle

#!/usr/local/bin/perl -w

use Tk;

use strict;

my $mw = MainWindow->new;

$mw->title('arc styles');

my $canvas = $mw->Canvas(qw/-width 180 -height 120/)->grid;

$canvas->createRectangle(qw/10 10 50 50/);

$canvas->createArc(qw/10 10 50 50 -start 0 -extent 270 -style piesl\

ice

-fill black -stipple error/);

$canvas->createRectangle(qw/70 10 110 50/);

$canvas->createArc(qw/70 10 110 50 -start 45 -extent -135 -style ch\

ord/);

$canvas->createRectangle(qw/130 10 170 50/);

$canvas->createArc(qw/130 10 170 50 -start -90 -extent -180 -style \

arc/);

$canvas->createText(85, 60, -text =>  'pieslice    chord        \

arc');

$canvas->createArc(qw/10 70 50 110 -start 0 -extent 270 -style pies\

lice

-fill black -stipple error/);

$canvas->createArc(qw/70 70 110 110 -start 45 -extent -135 -style c\

hord/);

$canvas->createArc(qw/130 70 170 110 -start -90 -extent -180 -style\

arc/);

MainLoop;

Issue_09_Tk 9. capstyle

Download capstyle

#!/usr/local/bin/perl -w

use Tk;

my $mw = MainWindow->new;

$mw->title('capstyles');

my $canvas = $mw->Canvas(qw/-width 160 -height 70/)->grid;

$canvas->createLine(qw/ 15 15  40 15 -width 20 -capstyle butt/);

$canvas->createLine(qw/ 15 15  40 15 -fill white/);

$canvas->createLine(qw/ 65 15  90 15 -width 20 -capstyle projecting\

/);

$canvas->createLine(qw/ 65 15  90 15 -fill white/);

$canvas->createLine(qw/115 15 140 15 -width 20 -capstyle round/);

$canvas->createLine(qw/115 15 140 15 -fill white/);

$canvas->createText(80, 60, -text =>  'butt  projecting  round')\

;

MainLoop;

Issue_09_Tk 10. join_style

Download join_style

#!/usr/local/bin/perl -w

use Tk;

my $mw = MainWindow->new;

$mw->title('joinstyles');

my $canvas = $mw->Canvas(qw/-width 160 -height 70/)->grid;

$canvas->createLine(qw/ 15 15  40 15  40 40 -width 20 -joinstyle be\

vel/);

$canvas->createLine(qw/ 65 15  90 15  90 40 -width 20 -joinstyle mi\

ter/);

$canvas->createLine(qw/115 15 140 15 140 40 -width 20 -joinstyle ro\

und/);

$canvas->createText(80, 60, -text => '  bevel     miter    round\

');

MainLoop;

Issue_09_Tk 11. joinstyle

Download joinstyle

#!/usr/local/bin/perl -w

use Tk;

my $mw = MainWindow->new;

$mw->title('joinstyles');

my $canvas = $mw->Canvas(qw/-width 160 -height 70/)->grid;

$canvas->createLine(qw/ 15 15  40 15  40 40 -width 20 -joinstyle be\

vel/);

$canvas->createLine(qw/ 65 15  90 15  90 40 -width 20 -joinstyle mi\

ter/);

$canvas->createLine(qw/115 15 140 15 140 40 -width 20 -joinstyle ro\

und/);

$canvas->createText(80, 60, -text => '  bevel     miter    round\

');

MainLoop;

Issue_09_Tk 12. spline

Download spline

#!/usr/local/bin/perl -w

use Tk;

my $mw = MainWindow->new;

$mw->title('spline');

my $canvas = $mw->Canvas(qw/-width 90 -height 100/)->grid;

$canvas->createLine(qw/10 25 20 55 48 15 80 95 -fill blue/);

$canvas->createLine(qw/10 25 20 55 48 15 80 95 -fill red smooth yes\

/);

MainLoop;

Issue_09_Tk 13. More Samples on Tk

• Issue_01_Tk
• Issue_02_Tk
• Issue_03_Tk
• Issue_04_Tk
• Issue_05_Tk
• Issue_06_Tk
• Issue_07_Tk
• Issue_09_Tk