diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib')
69 files changed, 7548 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Ball.pm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Ball.pm new file mode 100755 index 00000000000..c05605e4aaa --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Ball.pm @@ -0,0 +1,143 @@ + +package Ball; + +# Ball.pm, a class module that allows concurrent simulation (canvas) instances. +# +# This is simply a class module, nothing fancy like a derived widget or +# composite widget. It has two virtual methods, new() and move_one_ball(). +# There are two static methods, get_canvas_hash() and move_all_balls(). +# +# Essentially, move_all_balls() is invoked to move all of the balls in a +# simulation's @BALLS list once - from their current to their new postion. +# After moving one ball a call to DoOneEvent() is made to handle pending +# XEvents. The *user* of this module, in this case bounce.pl, has their +# own main loop which also calls DoOneEvent() and move_all_balls() to keep +# the simulation active. +# +# Gurusamy Sarathy (gsar@engin.umich.edu) +# Tidied up by SOL. + +use vars qw/$VERSION/; +$VERSION = '4.004'; # $Id: //depot/Tkutf8/demos/demos/widget_lib/Ball.pm#4 $ + +use Tk::Canvas; +use Tk::Widget; +use Tk qw/DoOneEvent DONT_WAIT/; +Construct Tk::Canvas 'Ball'; +use strict; + +# Class Ball global variables. + +my %BALLS = (); # hold @BALLS list on a per canvas basis +my (%DEFAULTS) = ( # Ball constructor option defaults + -color => 'blue', + -size => 20.0, + -position => [12.0,12.0], + -velocity => [6.0, 9.0], + ); + +sub new { # Ball object constructor + + # Create a new Ball object, which just happens to be a Canvas item. + # Fill-in values for defaulted parameters, create the oval item, and + # store object-specific information in the ball's hash. + # + # Finally, update the class global %BALLS hash, indexed by a hashed canvas + # reference, with the new ball. Note the special Tk::bind statement that + # removes a canvas from the %BALLS hash when the canvas is destroyed, thus + # keeping %BALLS trimmed and preventing a very slow memory leak. + + my($class, $canvas, %args) = @_; + + my @missing_args = grep ! defined $args{$_}, keys %DEFAULTS; + @args{@missing_args} = @DEFAULTS{@missing_args}; + my($color, $size, $pos, $vel) = @args{-color, -size, -position, -velocity}; + + my $ball = $canvas->create('oval', + ($pos->[0] - ($size/2.0)), ($pos->[1] - ($size/2.0)), + ($pos->[0] + ($size/2.0)), ($pos->[1] + ($size/2.0)), + -fill => $color, + ); + $canvas->Tk::bind( + '<Destroy>' => sub {delete $BALLS{Ball->get_canvas_hash($canvas)}} + ); + + my $ball_obj = {'canvas_ID' => $ball, + 'canvas' => $canvas, + 'color' => $color, + 'size' => $size, + 'pos' => [@$pos], + 'vel' => [@$vel], + }; + + push @{$BALLS{Ball->get_canvas_hash($canvas)}->{'BALLS'}}, $ball_obj; + return bless $ball_obj, $class; + +} # end new, Ball constructor + +sub get_canvas_hash { + + # Hash a canvas reference to a key for indexing into the %BALLS hash. + # For now, just use the string-ified widget reference. If this trick + # were ever to fail in the future then only this code needs to be fixed + # and the Ball class would be up and running in short oder. + + my($class, $canvas) = @_; + + return $canvas + +} # end get_canvas_hash + +sub move_one_ball { + + # Move one ball, belonging to one simulation, one clock tick. + + my ($ball_obj, $speed_ratio) = @_; + + my($ball, $canv, $minx, $miny, $maxx, $maxy); + my($ballx, $bally, $deltax, $deltay); + + $speed_ratio = 1.0 unless defined $speed_ratio; + $ball = $ball_obj->{'canvas_ID'}; + $canv = $ball_obj->{'canvas'}; + $ballx = $ball_obj->{'pos'}[0]; + $bally = $ball_obj->{'pos'}[1]; + + $minx = $ball_obj->{'size'} / 2.0; + $maxx = $ball_obj->{'canvas'}->cget(-width) - $minx; + + $miny = $ball_obj->{'size'} / 2.0; + $maxy = $ball_obj->{'canvas'}->cget(-height) - $miny; + + if ($ballx > $maxx || $ballx < $minx) { + $ball_obj->{'vel'}[0] = -1.0 * $ball_obj->{'vel'}[0]; + } + if ($bally > $maxy || $bally < $miny) { + $ball_obj->{'vel'}[1] = -1.0 * $ball_obj->{'vel'}[1]; + } + + $deltax = $ball_obj->{'vel'}[0] * $speed_ratio; + $deltay = $ball_obj->{'vel'}[1] * $speed_ratio; + + $canv->move($ball, $deltax, $deltay); + $ball_obj->{'pos'}[0] = $ballx + $deltax; + $ball_obj->{'pos'}[1] = $bally + $deltay; + + return $ball_obj; + +} # end move_one_ball + +sub move_all_balls { + + # Move all the balls belong to one simulation instance one clock tick. + + my($class, $canvas, $speed_ratio) = @_; + + foreach (@{$BALLS{Ball->get_canvas_hash($canvas)}->{'BALLS'}}) { + $_->move_one_ball($speed_ratio); + DoOneEvent(DONT_WAIT); # be kind and process XEvents if they arise + } + +} # end move_all_balls + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList.pl new file mode 100755 index 00000000000..62d683b2dbb --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList.pl @@ -0,0 +1,65 @@ +# HList, a hierarchial listbox widget. + +use Tk::HList; +use Cwd; +use subs qw/show_dir/; +use vars qw/$TOP $FILEIMG $FOLDIMG/; + +sub HList { + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'HList - A hierarchial listbox widget.', + -geometry_manager => 'grid', + ); + + my $h = $TOP->Scrolled(qw\HList -separator / -selectmode extended -width 30 + -height 20 -indent 35 -scrollbars se + -itemtype imagetext \ + )->grid(qw/-sticky nsew/); + $h->configure(-command => sub { + print "Double click $_[0], size=", $h->info('data', $_[0]) ,".\n"; + }); + + $FILEIMG = $TOP->Bitmap(-file => Tk->findINC('file.xbm')); + $FOLDIMG = $TOP->Bitmap(-file => Tk->findINC('folder.xbm')); + + my $root = Tk->findINC('demos'); + my $olddir = cwd; + chdir $root; + show_dir '.', $root, $h; + chdir $olddir; + my $b = $TOP->Button(-text => 'Select All', -command => [\&select_all, $h]); + Tk::grid($b); +} + +sub select_all +{ + my $h = shift; + my @list = $h->infoChildren(@_); + if (@list) + { + $h->selectionSet($list[0],$list[-1]); + foreach my $e (@list) + { + select_all($h,$e); + } + } +} + +sub show_dir { + my($entry_path, $text, $h) = @_; + opendir H, $entry_path; + my(@dirent) = grep ! /^\.\.?$/, sort(readdir H); + closedir H; + $h->add($entry_path, -text => $text, -image => $FOLDIMG, -data => 'DIR'); + while ($_ = shift @dirent) { + my $file = "$entry_path/$_"; + if (-d $file) { + show_dir $file, $_, $h; + } else { + my $size = -s $file; + $h->add($file, -text => $_, -image => $FILEIMG, -data => $size); + } + } +} # end show_dir diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList2.pl new file mode 100755 index 00000000000..10ada400a65 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/HList2.pl @@ -0,0 +1,124 @@ +# HList and ItemStyle, multicolumn listbox with individual cell styles. +# -*- perl -*- + +# +# $Id: $ +# Author: Slaven Rezic +# +# Copyright (C) 1999 Slaven Rezic. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# Mail: eserte@cs.tu-berlin.de +# WWW: http://user.cs.tu-berlin.de/~eserte/ +# + +use Tk::HList; +use Tk::ItemStyle; + +sub HList2 { + my($demo) = @_; + my $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'HList and ItemStyle, multicolumn listbox with individual cell styles.', + -geometry_manager => 'grid', + ); + + my $h = $TOP->Scrolled + (qw/HList + -header 1 + -columns 4 + -width 50 + -height 20/ + )->grid(qw/-sticky nsew/); + + for (0 .. 3) { + $h->header('create', $_, -text => 'Column ' . $_); + } + + my @img; + foreach ('Xcamel.gif', 'anim.gif', 'icon.gif', 'Camel.xpm') { + push @img, $TOP->Photo(-file => Tk->findINC($_)), + } + + my(@fonts) = ('-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*', + '-*-Courier-Medium-R-Normal--*-180-*-*-*-*-*-*', + '-*-times-medium-r-normal--*-240-*-*-*-*-*-*', + '-Adobe-Courier-Bold-O-Normal--*-120-*-*-*-*-*-*', + 'fixed', + ); + + my(@colors) = qw(red green blue yellow red cyan black); + + my $rnd_font = sub { + $fonts[rand($#fonts+1)]; + }; + my $rnd_color = sub { + $colors[rand($#colors+1)]; + }; + my $rnd_image = sub { + my $yn = int(rand(2)); + if ($yn) { + $img[rand($#img+1)]; + } else { + undef; + } + }; + my $rnd_window = sub { + my $yn = int(rand(10)); + if ($yn == 3) { + ('Button', 'Entry')[rand(2)]; + } else { + undef; + } + }; + + for my $y (0 .. 20) { + my $e = $h->addchild(""); + for my $col (0 .. 3) { + my $window = $rnd_window->(); + my $image = $rnd_image->(); + my $fg = $rnd_color->(); + my $bg = $rnd_color->(); + if ($bg eq $fg) { $fg = 'white' } + + my $style_type = ($window ? 'window' : + ($image ? 'imagetext' : 'text')); + my $btn; + my $style = $h->ItemStyle($style_type); + if ($style_type eq 'window') { + $style->configure(-pady => 0, -padx => 0, -anchor => "nw"); + if ($window eq 'Button') { + $btn = $h->Button + (-text => 'Click me!', + -command => sub { + $btn->configure(-activeforeground => $rnd_color->()); + }, + ); + } else { + $btn = $h->Entry; + } + } else { + $style->configure(-foreground => $fg, + -background => $bg, + -font => $rnd_font->(), + ); + } + $h->itemCreate + ($e, $col, + -itemtype => $style_type, + -style => $style, + ($style_type eq 'imagetext' + ? (-image => $image) : () + ), + ($style_type eq 'window' + ? (-widget => $btn) : (-text => 'Cell ' . $y . '/' . $col) + ), + ); + } + } +} + +1; + +__END__ diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Plot.pm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Plot.pm new file mode 100755 index 00000000000..5ce7791a7d9 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/Plot.pm @@ -0,0 +1,198 @@ + +package Plot; + +# Class "Plot": constructor, methods, destructor, global class data, +# etcetera. +# +# Because a Plot object is a composite widget all the Composite base +# class methods and advertised widgets are available to you. +# +# Advertised Plot widgets: canvas, entry, PostScript_button, view_button. + +require 5.005_03; + +use vars qw/$VERSION @ISA/; +$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; + +use Tk::Frame; +use base qw/Tk::Frame/; +Construct Tk::Widget 'Plot'; +use strict; + +sub Populate { + + # Plot composite widget constructor. + + my($cw, $args) = @_; + + $cw->SUPER::Populate($args); + my($tc, $ih, $ah) = ( + delete $args->{-title_color}, + delete $args->{-inactive_highlight}, + delete $args->{-active_highlight}, + ); + + my %pinfo; # plot information hash + $pinfo{'lastX'} = 0; + $pinfo{'lastY'} = 0; + $pinfo{'areaX2'} = -1; + $pinfo{'prcmd'} = 'lpr'; + + my $plot_font = '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*'; + + my $c = $cw->Canvas( + -relief => 'raised', + -width => '450', + -height => '300', + -cursor => 'top_left_arrow', + ); + $cw->Advertise('canvas' => $c); + $c->pack(-side => 'top', -fill => 'x'); + + $c->createLine(100, 250, 400, 250, -width => 2); + $c->createLine(100, 250, 100, 50, -width => 2); + $c->createText(225, 20, -text => 'A Simple Plot', -font => $plot_font, + -fill => $tc); + + my($i, $x, $y, $point, $item); + for($i = 0; $i <= 10; $i++) { + $x = 100 + ($i * 30); + $c->createLine($x, 250, $x, 245, -width => 2); + $c->createText($x, 254, -text => 10 * $i, -anchor => 'n', + -font => $plot_font); + } # forend + for ($i = 0; $i <= 5; $i++) { + $y = 250 - ($i * 40); + $c->createLine(100, $y, 105, $y, -width => 2); + $c->createText(96, $y, -text => $i * 50.0, -anchor => 'e', + -font => $plot_font); + } # forend + + foreach $point ([12, 56], [20, 94], [33, 98], [32, 120], [61, 180], + [75, 160], [98, 223]) { + $x = 100 + (3 * ${$point}[0]); + $y = 250 - (4 * ${$point}[1]) / 5; + $item = $c->createOval($x-6, $y-6, $x+6, $y+6, -width => 1, + -outline => 'black', -fill => $ih); + $c->addtag('point', 'withtag', $item); + } + + $c->bind('point', '<Any-Enter>' => [sub{shift->itemconfigure(@_)}, + 'current', -fill => $ah]); + $c->bind('point', '<Any-Leave>' => [sub{shift->itemconfigure(@_)}, + 'current', -fill => $ih]); + $c->bind('point', '<1>' => [sub {plot_down(@_)}, \%pinfo]); + $c->bind('point', '<ButtonRelease-1>' => sub {shift->dtag('selected')}); + $c->CanvasBind('<B1-Motion>' => [sub {plot_move(@_)}, \%pinfo]); + $c->CanvasBind('<2>' => [sub {area_down(@_)}, \%pinfo]); + $c->CanvasBind('<B2-Motion>' => [sub {area_move(@_)}, \%pinfo]); + + my $w_prcmd = $cw->Entry( + -textvariable => \$pinfo{'prcmd'}, + ); + $cw->Advertise('entry' => $w_prcmd); + $w_prcmd->pack; + + my $w_print = $cw->Button( + -text => 'Print in PostScript Format', + -command => [\&area_save, $c, \%pinfo], + ); + $cw->Advertise('PostScript_button' => $w_print); + $w_print->pack; + $w_prcmd->bind('<Return>' => [$w_print => 'invoke']); + + my $w_view = $cw->Button( + -text => 'View Composite Plot Widget', + -command => [\&::view_widget, + Tk->findINC('demos/widget_lib/Plot.pm'), + ], + ); + $cw->Advertise('view_button' => $w_view); + $w_view->pack; + + return $cw; + +} # end Populate, Plot constructor + +# Private methods. + +sub area_down { + + my($w, $pinfo) = @_; + + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + $pinfo->{'areaX1'} = $x; + $pinfo->{'areaY1'} = $y; + $pinfo->{'areaX2'} = -1; + $pinfo->{'areaY2'} = -1; + eval {local $SIG{'__DIE__'}; $w->delete('area');}; + +} # end area_down + +sub area_move { + + my($w, $pinfo) = @_; + + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + if($x != $pinfo->{'areaX1'} && $y != $pinfo->{'areaY1'}) { + eval {local $SIG{'__DIE__'}; $w->delete('area');}; + $w->addtag('area','withtag',$w->createRectangle($pinfo->{'areaX1'}, + $pinfo->{'areaY1'},$x,$y)); + $pinfo->{'areaX2'} = $x; + $pinfo->{'areaY2'} = $y; + } +} # end area_move + +sub area_save { + + my($w, $pinfo) = @_; + + my($x1, $x2, $y1, $y2, $a); + + if($pinfo->{'areaX2'} != -1) { + ($x1, $x2, $y1, $y2) = + @$pinfo{'areaX1', 'areaX2', 'areaY1', 'areaY2'}; # slice ! + ($x1, $x2) = @$pinfo{'areaX2', 'areaX1'} if $x2 <= $x1; + ($y1, $y2) = @$pinfo{'areaY2', 'areaY1'} if $y2 <= $y1; + $a = $w->postscript('-x' => $x1, '-y' => $y1, + -width => $x2 - $x1, -height => $y2 - $y1); + } else { + $a = $w->postscript; + } + + $SIG{'PIPE'} = sub {}; + open(LPR, "| $pinfo->{'prcmd'}"); + print LPR $a; + close(LPR); + +} # end area_save + +sub plot_down { + + my($w, $pinfo) = @_; + + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + $w->dtag('selected'); + $w->addtag('selected', 'withtag', 'current'); + $w->raise('current'); + $pinfo->{'lastX'} = $x; + $pinfo->{'lastY'} = $y; + +} # end plot_down + +sub plot_move { + + my($w, $pinfo) = @_; + + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + $w->move('selected', $x-$pinfo->{'lastX'}, $y-$pinfo->{'lastY'}); + $pinfo->{'lastX'} = $x; + $pinfo->{'lastY'} = $y; + +} # end plot_move + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm new file mode 100755 index 00000000000..61513b657ea --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm @@ -0,0 +1,130 @@ +package WidgetDemo; + +use 5.005_03; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/; + +use Tk 800.000; +use Carp; + +use Tk; +use Tk::Toplevel; +use strict; +use base 'Tk::Toplevel'; +Construct Tk::Widget 'WidgetDemo'; + +# %WIDGDEMO is a class global that tracks all WidgetDemo composite widgets, +# providing a means of destroying a previous instance of a demonstration. + +my %WIDGDEMO; # class hash of active widget demonstrations + +sub Populate { + my($self, $args) = @_; + + my (%arg_defaults) = ( + -name => 'Unknown Demo Name', + -font => 'Helvetica 12', + -text => 'Unknown Demo Text', + -geometry_manager => 'pack', + ); + my $name = $arg_defaults{-name}; + $arg_defaults{-title} = "$name Demonstration", + $arg_defaults{-iconname} = $name; + + my(@margs, %ahsh, @args); + @margs = grep ! defined $args->{$_}, keys %arg_defaults; + %ahsh = %$args; + @ahsh{@margs} = @arg_defaults{@margs}; + my($demo, $font, $text, $title, $iconname, $gm) = + @ahsh{-name, -font, -text, -title, -iconname, -geometry_manager}; + delete $args->{-name}; + delete $args->{-font}; + delete $args->{-iconname}; + delete $args->{-geometry_manager}; + + $WIDGDEMO{$demo}->destroy if Exists($WIDGDEMO{$demo}); + $WIDGDEMO{$demo} = $self; + + $self->SUPER::Populate($args); + $self->iconname($iconname); + + my(@label_attributes) = (); + if (ref($text) eq 'ARRAY') { + @label_attributes = @$text[1 .. $#{$text}]; + $text = $text->[0]; + } + my $msg = $self->Label( + -font => $font, + -wraplength => '4i', + -justify => 'left', + -text => $text, + @label_attributes, + ); + + my $demo_frame = $self->Frame; + $self->Advertise('WidgetDemo' => $demo_frame); # deprecated + + my $buttons = $self->Frame; + my $dismiss = $buttons->Button( + -text => 'Dismiss', + -command => [$self => 'destroy'], + ); + my $see = $buttons->Button(-text => 'See Code', + -command => [\&main::see_code, $demo]); + + if ($gm eq 'pack') { + $buttons->pack(qw/-side bottom -fill x -pady 2m/); + $dismiss->pack(qw/-side left -expand 1/); + $see->pack(qw/-side left -expand 1/); + $msg->pack; + $demo_frame->pack(qw/-fill both -expand 1 -anchor n/); + } elsif ($gm eq 'grid') { + $msg->grid; + $demo_frame->grid(-sticky => "news"); + $demo_frame->gridColumnconfigure(0,-weight=>1); + $demo_frame->gridRowconfigure(0,-weight=>1); + $self->gridColumnconfigure(qw/0 -weight 1/); + $self->gridRowconfigure(qw/1 -weight 1/); + $buttons->grid(qw/-pady 2m -sticky ew/); + $buttons->gridColumnconfigure(qw/0 -weight 1/); + $buttons->gridColumnconfigure(qw/1 -weight 1/); + $dismiss->grid(qw/-row 0 -column 0/); + $see->grid(qw/-row 0 -column 1/); + } else { + croak "Only pack or grid geometry management supported."; + } + + $self->Delegates('Construct' => $demo_frame); + + $self->ConfigSpecs( + -text => [qw/METHOD text Text NoText/], + ); + + $self->{msg} = $msg; + + return $self; + +} # end Populate + +sub Top {return $_[0]->Subwidget('WidgetDemo')} # deprecated +*top = *top = \&Top; # peacify -w + +sub text { + + my ($self, $text) = @_; + + my(@label_attributes) = (); + if (ref($text) eq 'ARRAY') { + @label_attributes = @$text[1 .. $#{$text}]; + $text = $text->[0]; + } + + $self->{msg}->configure( + -text => $text, + @label_attributes, + ); + +} # end text + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/arrows.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/arrows.pl new file mode 100755 index 00000000000..de4973071b9 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/arrows.pl @@ -0,0 +1,242 @@ +# arrows.pl + +use subs qw/arrow_err arrow_move1 arrow_move2 arrow_move3 arrow_setup/; +use vars qw/$TOP/; + +sub arrows { + + # Create a top-level window containing a canvas demonstration that + # allows the user to experiment with arrow shapes. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you\'d enter them for a canvas line item.', qw/-wraplength 5i/], + -title => 'Arrowhead Editor Demonstration', + -iconname => 'arrows', + ); + + my $c = $TOP->Canvas( + -width => '500', + -height => '350', + -relief => 'sunken', + -borderwidth => 2, + )->pack(qw/-expand yes -fill both/); + + my %ainfo; # arrow information hash + $ainfo{a} = 8; + $ainfo{b} = 10; + $ainfo{c} = 3; + $ainfo{width} = 2; + $ainfo{move_sub} = undef; + $ainfo{x1} = 40; + $ainfo{x2} = 350; + $ainfo{'y'} = 150; + $ainfo{smallTips} = [5, 5, 2]; + $ainfo{count} = 0; + + if ($TOP->depth > 1) { + $ainfo{bigLineStyle} = [qw/-fill SkyBlue1/]; + $ainfo{boxStyle} = [-fill => undef, qw/-outline black -width 1/]; + $ainfo{activeStyle} = [qw/-fill red -outline black -width 1/]; + } else { + $ainfo{bigLineStyle} = [ + -fill => 'black', + -stipple => '@'.Tk->findINC('demos/images/grey.25'), + ]; + $ainfo{boxStyle} = [-fill => undef, qw/-outline black -width 1/]; + $ainfo{activeStyle} = [qw/-fill black -outline black -width 1/]; + } + arrow_setup $c, \%ainfo; + + # Bindings to highlight the 3 tiny resize boxes. + + foreach ([qw/<Enter> activeStyle/], [qw/<Leave> boxStyle/]) { + $c->bind('box', $_->[0] =>[ + sub { + my($c, $style) = @_; + $c->itemconfigure('current', @{$ainfo{$style}}) + }, $_->[1]], + ); + } + $c->bind(qw/box <B1-Enter>/ => 'NoOp'); + $c->bind(qw/box <B1-Leave>/ => 'NoOp'); + + # Bindings that select one of the 3 tiny resize boxes' "move code". + + my $n; + for $n (1,2,3) { + $c->bind("box${n}", '<1>' => + sub {$ainfo{move_sub} = \&{"arrow_move${n}"}} + ); + } + + # Bindings to move a resize box and redraw the arrow. + + $c->bind('box', '<B1-Motion>' => + sub {&{$ainfo{move_sub}}($c, \%ainfo)} + ); + $c->Tk::bind('<Any-ButtonRelease-1>' => [\&arrow_setup, \%ainfo]); + +} # end arrows + +sub arrow_err { + + my($c) = @_; + + my $i = $c->createText(qw/.6i .1i -anchor n -text/ => "Range error!"); + $c->after(4000, sub { $c->delete($i) }); + +} # end errow_err + +sub arrow_move1 { + + my($c, $v) = @_; + my $e = $c->XEvent; + + my($x, $y, $err) = ($e->x, $e->y, 0); + my $newA = int(($v->{x2} + 5 - int($c->canvasx($x))) / 10); + $newA = 0, $err = 1 if $newA < 0; + $newA = 25, $err = 1 if $newA > 25; + if ($newA != $v->{a}) { + $c->move('box1', 10 * ($v->{a} - $newA), 0); + $v->{a} = $newA; + } + arrow_err($c) if $err; + +} # end arrow_move1 + +sub arrow_move2 { + + my($c, $v) = @_; + my $e = $c->XEvent; + + my($x, $y, $errx, $erry) = ($e->x, $e->y, 0, 0); + my $newB = int(($v->{x2} + 5 - int($c->canvasx($x))) / 10); + $newB = 0, $errx = 1 if $newB < 0; + $newB = 25, $errx = 1 if $newB > 25; + my $newC = int(($v->{'y'} + 5 - int($c->canvasy($y)) - 5 * $v->{width}) + / 10); + $newC = 0, $erry = 1 if $newC < 0; + $newC = 12, $erry = 1 if $newC > 12; + if (($newB != $v->{b}) or ($newC != $v->{c})) { + $c->move('box2', 10*($v->{b}-$newB), 10*($v->{c}-$newC)); + $v->{b} = $newB; + $v->{c} = $newC; + } + arrow_err($c) if $errx or $erry; + +} # end arrow_move2 + +sub arrow_move3 { + + my($c, $v) = @_; + my $e = $c->XEvent; + + my($x, $y, $err) = ($e->x, $e->y, 0); + my $newWidth = int(($v->{'y'} + 2 - int($c->canvasy($y))) / 5); + $newWidth = 0, $err = 1 if $newWidth < 0; + $newWidth = 20, $err = 1 if $newWidth > 20; + if ($newWidth != $v->{width}) { + $c->move('box3', 0, 5*($v->{width}-$newWidth)); + $v->{width} = $newWidth; + } + arrow_err($c) if $err; + +} # end arrow_move3 + +sub arrow_setup { + + # The procedure below completely regenerates all the text and graphics in + # the canvas window. It's called when the canvas is initially created, + # and also whenever any of the parameters of the arrow head are changed + # interactively. The argument is the name of the canvas widget to be + # regenerated, and also the name of a global variable containing the + # parameters for the display. + + my($c, $v) = @_; + + # Remember the current box, if there is one. + + my(@tags) = $c->gettags('current'); + my $cur = defined $tags[0] ? $tags[lsearch('box?', @tags)] : ''; + + # Create the arrow and outline. + + $c->delete('all'); + $c->createLine($v->{x1}, $v->{'y'}, $v->{x2}, $v->{'y'}, + -width => 10*$v->{width}, + -arrowshape => [10*$v->{a}, 10*$v->{b}, 10*$v->{c}], + -arrow => 'last', @{$v->{bigLineStyle}}); + my $xtip = $v->{x2}-10*$v->{b}; + my $deltaY = 10*$v->{c}+5*$v->{width}; + $c->createLine($v->{x2}, $v->{'y'}, $xtip, $v->{'y'}+$deltaY, + $v->{x2}-10*$v->{a}, $v->{'y'}, $xtip, $v->{'y'}-$deltaY, + $v->{x2}, $v->{'y'}, -width => 2, -capstyle => 'round', + -joinstyle => 'round'); + + # Create the boxes for reshaping the line and arrowhead. + + $c->createRectangle($v->{x2}-10*$v->{a}-5, $v->{'y'}-5, + $v->{x2}-10*$v->{a}+5, $v->{'y'}+5, @{$v->{boxStyle}}, + -tags => ['box1', 'box']); + $c->createRectangle($xtip-5, $v->{'y'}-$deltaY-5, $xtip+5, + $v->{'y'}-$deltaY+5, @{$v->{boxStyle}}, + -tags => ['box2', 'box']); + $c->createRectangle($v->{x1}-5, $v->{'y'}-5*$v->{width}-5, + $v->{x1}+5, $v->{'y'}-5*$v->{width}+5, @{$v->{boxStyle}}, + -tags => ['box3', 'box']); + + # Create three arrows in actual size with the same parameters + + $c->createLine($v->{x2}+50, 0, $v->{x2}+50, 1000, -width => 2); + my $tmp = $v->{x2}+100; + $c->createLine($tmp, $v->{'y'}-125, $tmp, $v->{'y'}-75, + -width => $v->{width}, -arrow => 'both', + -arrowshape => [$v->{a}, $v->{b}, $v->{c}]); + $c->createLine($tmp-25, $v->{'y'}, $tmp+25, $v->{'y'}, + -width => $v->{width}, -arrow => 'both', + -arrowshape =>[$v->{a}, $v->{b}, $v->{c}]); + $c->createLine($tmp-25, $v->{'y'}+75, $tmp+25, $v->{'y'}+125, + -width => $v->{width}, -arrow => 'both', + -arrowshape => [$v->{a}, $v->{b}, $v->{c}]); + $c->itemconfigure($cur, @{$v->{activeStyle}}) if $cur =~ /box?/; + + # Create a bunch of other arrows and text items showing the current + # dimensions. + + $tmp = $v->{x2}+10; + $c->createLine($tmp, $v->{'y'}-5*$v->{width}, $tmp, $v->{'y'}-$deltaY, + -arrow => 'both', -arrowshape => $v->{smallTips}); + $c->createText($v->{x2}+15, $v->{'y'}-$deltaY+5*$v->{c}, + -text => $v->{c}, -anchor => 'w'); + $tmp = $v->{x1}-10; + $c->createLine($tmp, $v->{'y'}-5*$v->{width}, $tmp, + $v->{'y'}+5*$v->{width}, -arrow => 'both', + -arrowshape => $v->{smallTips}); + $c->createText($v->{x1}-15, $v->{'y'}, -text => $v->{width}, + -anchor => 'e'); + $tmp = $v->{'y'}+5*$v->{width}+10*$v->{c}+10; + $c->createLine($v->{x2}-10*$v->{a}, $tmp, $v->{x2}, $tmp, + -arrow => 'both', -arrowshape => $v->{smallTips}); + $c->createText($v->{x2}-5*$v->{a}, $tmp+5, -text => $v->{a}, + -anchor => 'n'); + $tmp = $tmp+25; + $c->createLine($v->{x2}-10*$v->{b}, $tmp, $v->{x2}, $tmp, + -arrow => 'both', -arrowshape => $v->{smallTips}); + $c->createText($v->{x2}-5*$v->{b}, $tmp+5, -text => $v->{b}, + -anchor => 'n'); + + $c->createText($v->{x1}, 310, -text => "-width => $v->{width}", + -anchor => 'w', + -font => '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*'); + $c->createText($v->{x1}, 330, + -text => "-arrowshape => [$v->{a}, $v->{b}, $v->{c}]", + -anchor => 'w', + -font => '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*'); + + $v->{count}++; + +} # end arrow_setup + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/balloon.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/balloon.pl new file mode 100755 index 00000000000..630ac957950 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/balloon.pl @@ -0,0 +1,168 @@ +# Balloon, pop up help window when mouse lingers over widget. + +use Tk; +use English; +use Carp; + +use Tk::Frame; +use Tk::Balloon; + +my $lmsg = ""; + +my $top = MainWindow->new; +my $f = $top->Frame; + +# status bar widget +my $status = $top->Label(-width => 60, -relief => "sunken", -bd => 1, -anchor => 'w'); +$status->pack(-side => "bottom", -fill => "y", -padx => 2, -pady => 1); + +# create the widgets to be explained +my $mb = $top->Menubutton(-relief => 'raised', + -text => 'Menu button'); +my $xxx = 0; +$mb->checkbutton(-label => 'checkbutton', + -variable => \$xxx); +$mb->cascade(-label => 'cascade entry'); +my $menu = $mb->cget(-menu); +my $cm = $menu->Menu(-tearoff => 0); +$mb->entryconfigure('cascade entry', -menu => $cm); +$cm->command(-label => 'first'); +$cm->command(-label => 'second'); +$mb->separator; +$mb->command(-label => 'Close', + -command => sub {$top->destroy;}); + +my $tm = $top->Menu(-title => "Balloon menu"); +$tm->cascade(-label => "Toplevel menu", -menu => $menu); +$top->configure(-menu => $tm); + +my $b1 = $top->Button(-text => "Something Unexpected", + -command => sub {$top->destroy;}); +my $b2 = $top->Button(-text => "Something Else Unexpected"); +$b2->configure(-command => sub {$b2->destroy;}); + +# Pack the created widgets: +$mb->pack(-side => "top", -expand => 1); +$b1->pack(-side => "top", -expand => 1); +$b2->pack(-side => "top", -expand => 1); + +my $t = $top->Text(-height => 10, -cursor => 'top_left_arrow')->pack; +$t->insert('end',<<END); + +Move the mouse cursor over the buttons above and let it linger. +A message will be displayed in status box below and a descriptive +balloon will appear. The top button is a menu button which has +different messages set for each menu entry. This text widget has +a balloon attached to it which will change depending on which word +the mouse is over. + +END + +my $clbf = $top->Frame->pack; +my $cf = $clbf->Frame->pack(-side => "left"); + +my $c1 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8); +my $c2 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8); +my $id = $c1->create('text', 10, 10, + -anchor => 'nw', + -text => "This is a canvas. You can also attach\nballoons to specific items in a canvas"); +$c1->create('rectangle', 40, 60, 80, 80, + -fill => 'red', + -tags => 'rectangle',); +$c1->create('oval', 100, 50, 140, 90, + -fill => 'blue', + -tags => 'circle',); +$c2->create('text', 10, 10, + -anchor => 'nw', + -text => "Or you can attach the balloon\nto the canvas as a whole."); + +my $lb = $clbf->Listbox->pack(-side => "left"); +$lb->insert(qw/end one two three four/); + +# create the balloon widget +my $b = $top->Balloon(-statusbar => $status); + +$b->attach($mb, + -msg => 'Press and hold this button to see the menu.'); +$b->attach($menu, + #-state => 'status', + -balloonposition => 'mouse', + -msg => ['Use this to tear off the menu.', + 'This is a checkbox entry.', + 'cascade', # Cascade entry (ignored by Balloon) + 'separator', # Separator: never active so no message will be displayed for this entry. + 'This is a command entry - it will close this window.', + ], + ); +$b->attach($cm, + -msg => 'This balloon is attached to the cascade menu, not it\'s entries', + #-statusmsg => 'msg cm', + #-balloonmsg => 'cm msg.', + ); +$b->attach($b1, + -balloonmsg => "Close Window", + -statusmsg => "Press this button to close this window"); +$b->attach($b2, + -balloonmsg => "Self-destruct\nButton", + -statusmsg => "Press this button and it will get rid of itself"); + +my $msg = ''; +my @word = ('', ''); # Indicies surrounding the current word. +my @last = ('', ''); # Same for last word. +$b->attach($t, -msg => \$msg, + -balloonposition => 'mouse', # Not really used since the postcommand returns the real position. + -postcommand => sub { if ($word[0] eq $word[1]) { + # No word under mouse - don't post the balloon. + 0; + } else { + # Have a word under mouse - change the message: + my $word = $t->get($word[0], $word[1]); + # Skip it if it contains non-word chars: + return 0 if $word =~ /\W/; + $msg = "The word under the mouse is: $word"; + $t->tag('add', 'sel', $word[0] => $word[1]); + # Find a good place to put the balloon (right below the last char in the word): + my $i = $t->index("$word[1] - 1 chars"); + my @p = $t->bbox($i); + my $x = $t->rootx + $p[0] + $p[2] - 4; + my $y = $t->rooty + $p[1] + $p[3] + 2; + "$x,$y"; + } + }, + -motioncommand => sub { my $x = $t->pointerx - $t->rootx; + my $y = $t->pointery - $t->rooty; + @word = ($t->index("\@$x,$y wordstart"), $t->index("\@$x,$y wordend")); + if ($word[0] eq $last[0] and $word[1] eq $last[1]) { + # Same word - don't cancel the balloon. + 0; + } else { + # New word under mouse - cancel it so a new balloon will be posted. + $t->SelectionClear; + @last = @word; + 1; + } + }, + ); +$b->attach($c1, + -balloonposition => 'mouse', + -msg => {'rectangle' => 'You are over the red rectangle right now.', + $id => 'You are over the text right now.', + 'circle' => 'You are over the blue circle right now.', + }); +$b->attach($c2, + -msg => 'This balloon is attached to the canvas itself.', + ); + +$b->attach($lb, + -balloonposition => 'mouse', + -msg => [qw/1 2 3 4/], + ); + +# As $b is a child of $top it is destroyed when $top is destroyed. +# Balloon.pm now registers a handler for that, and so +# this hackery is no longer required (and did not actually work +# before). +# $top->OnDestroy(sub { $b->destroy; }); + +MainLoop; + diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bind.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bind.pl new file mode 100755 index 00000000000..65579183a91 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bind.pl @@ -0,0 +1,65 @@ +# bind.pl + +use vars qw/$TOP/; + +sub bind { + + # Create a top-level window that illustrates how you can bind Perl + # commands to regions of text in a text widget. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text =>'', + -title => 'Text Demonstration - Tag Bindings', + -iconname => 'bind', + ); + + my $t = $TOP->Scrolled(qw/Text -setgrid true -width 60 -height 24 + -scrollbars e -wrap word/, -font => $FONT); + $t->pack(qw/-expand yes -fill both/); + + # Set up display styles + + my(@bold, @normal, $tag); + if ($TOP->depth > 1) { + @bold = (-background => '#43ce80', qw/-relief raised -borderwidth 1/); + @normal = (-background => undef, qw/-relief flat/); + } else { + @bold = (qw/-foreground white -background black/); + @normal = (-foreground => undef, -background => undef); + } + + $t->insert('0.0', "The same tag mechanism that controls display styles in text widgets can also be used to associate Perl commands with regions of text, so that mouse or keyboard actions on the text cause particular Perl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 1 over a description then that particular demonstration is invoked.\n\n"); + $t->insert('end','1. Samples of all the different types of items that can be created in canvas widgets.', 'd1'); + $t->insert('end', "\n\n"); + $t->insert('end', '2. A simple two-dimensional plot that allows you to adjust the positions of the data points.', 'd2'); + $t->insert('end', "\n\n"); + $t->insert('end', '3. Anchoring and justification modes for text items.', 'd3'); + $t->insert('end', "\n\n"); + $t->insert('end', '4. An editor for arrow-head shapes for line items.', 'd4'); + $t->insert('end', "\n\n"); + $t->insert('end', '5. A ruler with facilities for editing tab stops.', 'd5'); + $t->insert('end', "\n\n"); + $t->insert('end', '6. A grid that demonstrates how canvases can be scrolled.', 'd6'); + + foreach $tag (qw(d1 d2 d3 d4 d5 d6)) { + $t->tagBind($tag, '<Any-Enter>' => + sub {shift->tagConfigure($tag, @bold)} + ); + $t->tagBind($tag, '<Any-Leave>' => + sub {shift->tagConfigure($tag, @normal)} + ); + } + $t->tagBind(qw/d1 <1>/ => sub {&items('items')}); + $t->tagBind(qw/d2 <1>/ => sub {&plot('plot')}); + $t->tagBind(qw/d3 <1>/ => sub {&ctext('ctext')}); + $t->tagBind(qw/d4 <1>/ => sub {&arrows('arrows')}); + $t->tagBind(qw/d5 <1>/ => sub {&ruler('ruler')}); + $t->tagBind(qw/d6 <1>/ => sub {&cscroll('cscroll')}); + + $t->mark(qw/set insert 0.0/); + +} # end bind + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bitmaps.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bitmaps.pl new file mode 100755 index 00000000000..8001e884b2d --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bitmaps.pl @@ -0,0 +1,44 @@ +# bitmaps.pl + +use subs qw/bitmaps_row/; +use vars qw/$TOP/; + +sub bitmaps { + + # Create a top-level window that displays all of Tk's built-in bitmaps. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'This window displays all of Tk\'s built-in bitmaps, along with the names you can use for them in Perl scripts.', + -title => 'Bitmap Demonstration', + -iconname => 'bitmaps', + ); + + my $frame = $TOP->Frame; + $frame->pack(qw/-side top -expand yes -fill both/); + bitmaps_row $frame, qw/error gray12 gray25 gray50 gray75 hourglass/; + bitmaps_row $frame, qw/info questhead question Tk transparent warning/; + +} # end bitmaps + +sub bitmaps_row { + + # The procedure below creates a new row of bitmaps in a window. + + my($w, @names) = @_; + + my $row = $w->Frame->pack(qw/-side top -fill both/); + + foreach my $bitmap_name (@names) { + my $bit = $row->Frame; + $bit->pack(qw/-side left -fill both -pady .25c -padx .25c/); + my $label = $bit->Label(-text => $bitmap_name, -width => 9); + $label->pack(qw/-side bottom/); + my $bitmap = $bit->Label('-bitmap' => $bitmap_name); + $bitmap->pack(qw/-side bottom/); + } + +} # end bitmaps_row + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bounce.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bounce.pl new file mode 100755 index 00000000000..a6012fb818b --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/bounce.pl @@ -0,0 +1,274 @@ +# bounce.pl + +use Ball; +use Tk qw/:eventtypes/; +use subs qw/ClearMsg DoSingleStep NotDone ShowMsg SimStart SimStop mkmb/; +use vars qw/$TOP/; + +my(@menu_button_list, $quit_flag, $quit_code, + $bounce_status, $bounce_speed, $bounce_running, $bounce_counter); + +sub bounce { + + # This began as a borrowed idea from Python distribution examples, ended up + # with a Ball module of its own. It illustrates how one can run something + # without blocking XEvent processing in a simple-minded sorta way. + # + # Handles resizes to the main window + # + # Gurusamy Sarathy (gsar@engin.umich.edu) + # Tidied up by SOL. + # + # 97/06/10 This demo is sufficiently bizarre enough that we don't use + # WidgetDemo! (-: Plus, you get to see Exists() in action. + + my($demo) = @_; + + $TOP->destroy if Exists($TOP); + $TOP = $MW->Toplevel; + $TOP->title('Bouncing Ball Simulator'); + $TOP->iconname('bounce'); + + @menu_button_list = (); + $quit_flag = 0; + $quit_code = sub {$quit_flag = 1}; + $TOP->protocol('WM_DELETE_WINDOW' => $quit_code); + + my $menubar = $TOP->Frame(qw/-relief raised -background DarkGreen -bd 2/); + $menubar->pack(-side => 'top', -fill => 'x'); + + mkmb($menubar, 'File', 0, 'File related stuff', + [ + ['Open', \&NotDone, 0], + ['New', \&NotDone, 0], + ['Print', \&NotDone, 0], + ['Exit', sub{$TOP->bell}, 0], + ]); + + mkmb($menubar, 'Simulate', 0, 'Simulator control', + [ + ['Start', \&SimStart, 2], + ['Stop', \&SimStop, 2], + ]); + + mkmb($menubar, 'Display', 0, 'Display settings', + [ + ['Redraw', \&NotDone, 2], + ['Clear', \&NotDone, 2], + ]); + + mkmb($menubar, 'Options', 0, 'Various preferences', + [ + ['Steptime', \&NotDone, 0], + ['Colors', \&NotDone, 0], + ['Display', \&NotDone, 0], + ]); + + mkmb($menubar, 'Help', 0, 'There when you need it', + [ + ['About..', \&NotDone, 0], + ['Intro', \&NotDone, 0], + ['Contents', \&NotDone, 0], + ]); + $menu_button_list[$#menu_button_list]->pack(-side => 'right'); + + my $feedback = $TOP->Frame(); + $feedback->pack(-side => 'bottom', -fill => 'x'); + $bounce_status = $feedback->Text( + -relief => 'sunken', + -height => 1, + -background => 'gray', + -borderwidth => 2, + ); + $bounce_status->pack(-side => 'left', -fill => 'x', -expand => 1); + + my $drawarea = $TOP->Frame(); + $drawarea->pack(-side => 'top', -fill => 'both', -expand => 1); + + my $canvas = $drawarea->Canvas( + -relief => 'ridge', + -height => 400, + -width => 600, + -borderwidth => 2, + ); + $canvas->pack(-side => 'left', -fill => 'both', -expand => 1); + + $bounce_speed = $drawarea->Scale( + -orient => 'vert', + -showvalue => 0, + -width => 10, + -from => 100, + -to => 0, + -borderwidth => 1, + ); + $bounce_speed->pack(-side => 'left', -fill => 'y'); + $bounce_speed->bind('<Enter>' => sub { + ClearMsg; ShowMsg('Adjust slider for ball speed'); + }); + $bounce_speed->bind('<Leave>' => \&ClearMsg); + $bounce_speed->set(50); + + my $w_buttons = $TOP->Frame; + $w_buttons->pack(qw(-side bottom -expand y -fill x -pady 2m)); + my $w_dismiss = $w_buttons->Button( + -text => 'Dismiss', + -command => $quit_code, + ); + $w_dismiss->pack(qw(-side left -expand 1)); + my $w_see = $w_buttons->Button( + -text => 'See Code', + -command => [\&see_code, $demo], + ); + $w_see->pack(qw(-side left -expand 1)); + my $w_ball = $w_buttons->Button( + -text => 'View Ball Class Module', + -command => [\&view_widget, + Tk->findINC('demos/widget_lib') . '/Ball.pm'], + ); + $w_ball->pack(qw(-side left -expand 1)); + + $bounce_running = 0; + $menu_button_list[1]->cget(-menu)->entryconfigure(1, -state => 'disabled'); + + $canvas->Ball; + $canvas->Ball(-color => 'red', -size => 30, -position => [200, 75]); + $canvas->Ball( + -color => 'green', + -size => 60, + -position => [490, 275], + -velocity => [8.0, 12.0], + ); + $canvas->Ball( + -color => 'yellow', + -size => 100, + -position => [360, 60], + -velocity => [8.0, 12.0], + ); + + $bounce_counter = 0; + $TOP->repeat(1000 => sub { + return unless $bounce_running; + ClearMsg; + ShowMsg(sprintf("%6d interations/second", $bounce_counter)); + $bounce_counter = 0 + }); + + + # This runs the Tk mainloop. Note that the simulation itself has a main + # loop which must be processed. DoSingleStep runs a bit of the simulation + # during every iteration. Also note that, with a flag of 0, + # Tk::DoOneEvent will suspend the process until an X-event arrives, + # effectively blocking the while loop. + # + # My original idea was to run the simulation mainloop as an asynchronous + # proc handler that runs when Tk is idle, but the necessary Async(3) calls + # from Tcl haven't made it into nTk yet. + + while (1) { + if ($quit_flag) { + $TOP->destroy; + return; + } + DoOneEvent($bounce_running ? DONT_WAIT : ALL_EVENTS); + DoSingleStep($canvas) if $bounce_running; + } + +} # end bounce + +sub mkmb { + + # (Ripped from nTk examples) + # Make a Menubutton widget; note that the menu is automatically created. + # We maintain a list of the Menubutton references since some callers + # need to refer to the Menubutton, as well as to suppress stray name + # warnings with Perl -w. + + my($mb0, $mb_label, $mb_label_underline, $mb_msg, $mb_list_ref) = @_; + my $mb = $mb0->Menubutton( + -text => $mb_label, + -underline => $mb_label_underline, + -background => 'DarkGreen', + -foreground => 'Yellow', + ); + my($menu) = $mb->Menu(-tearoff => 0); + $mb->configure(-menu => $menu); + + my $mb_list; + foreach $mb_list (@{$mb_list_ref}) { + $mb->command( + -label => $mb_list->[0], + -command => $mb_list->[1] , + -underline => $mb_list->[2], + -background => 'DarkGreen', + -foreground => 'White', + ); + } + $mb->pack(-side => 'left'); + $TOP->bind($mb, '<Enter>' => sub {ClearMsg; ShowMsg($mb_msg)}); + $TOP->bind($mb, '<Leave>' => \&ClearMsg); + + push @menu_button_list, $mb; + return $mb; + +} # end mkmb + +sub SimStart { + + if (not $bounce_running) { + $bounce_running = 1; + $menu_button_list[1]->cget(-menu)->entryconfigure(0, + -state => 'disabled', + ); + $menu_button_list[1]->cget(-menu)->entryconfigure(1, + -state => 'normal', + ); + } + +} # end SimStart + +sub SimStop { + + if ($bounce_running) { + $bounce_running = 0; + $menu_button_list[1]->cget(-menu)->entryconfigure(0, + -state => 'normal', + ); + $menu_button_list[1]->cget(-menu)->entryconfigure(1, + -state => 'disabled', + ); + } + +} # end SimStop + +sub NotDone { + + print "Not yet implemented.\n"; + +} # end NotDone + +sub ShowMsg { + + my($msg) = shift; + $bounce_status->insert('1.0', $msg); + +} # end ShowMsg + +sub ClearMsg { + + $bounce_status->delete('1.0', 'end'); + +} # end ClearMsg + +sub DoSingleStep { + + # The simulation handler. + # + # Note that this handler must be cooperative and return after a short + # period, so that other X events may be processed by the mainloop below. + + my($canvas) = @_; + + $bounce_counter++; + Ball->move_all_balls($canvas, $bounce_speed->get() / 100.0); + +} # end DoSingle Step diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry.pl new file mode 100755 index 00000000000..ce32f13934b --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry.pl @@ -0,0 +1,34 @@ +# BrowseEntry, entry with listbox to select list values. + +use Tk::BrowseEntry; + +my $month = "January"; + +outer: +{ + my $top = MainWindow->new; + my $f = $top->Frame; + my $c = $f->BrowseEntry(-label => "Month:", -variable => \$month); + $c->pack; + $c->insert("end", "January"); + $c->insert("end", "February"); + $c->insert("end", "March"); + $c->insert("end", "April"); + $c->insert("end", "May"); + $c->insert("end", "June"); + $c->insert("end", "July"); + $c->insert("end", "August"); + $c->insert("end", "September"); + $c->insert("end", "October"); + $c->insert("end", "November"); + $c->insert("end", "December"); + my $bf = $f->Frame; + $bf->Button(-text => "Print value", + -command => sub { + print "The month is $month\n"; + }, -relief => "raised")->pack; + + $bf->pack; + $f->pack; + MainLoop; +} diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry2.pl new file mode 100755 index 00000000000..5c8f9919847 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/browseentry2.pl @@ -0,0 +1,39 @@ +# BrowseEntry, another example. +# +# Chris Dean <ctdean@cogit.com> + +use strict; +use Tk; +use Tk::BrowseEntry; + +my $top = new MainWindow( -title => "BrowseEntry 2" ); +main( $top ); +MainLoop(); + +sub main { + my( $top ) = @_; + + my @countries = qw( America Belize Canada Denmark Egypt Fruitopia ); + my @states = qw( normal readonly disabled ); + foreach my $i (0..$#states) { + my $state = $states[$i]; + my $var = $countries[$i]; + my $f = $top->Frame->pack( qw/-side left/ ); + my $be = $f->BrowseEntry( -variable => \$var, + -choices => \@countries, + -state => $state )->pack; + if( $state eq "disabled" ) { + $be->configure( -arrowimage => $f->Getimage( "balArrow" ) ) + } + foreach my $s (@states) { + $f->Radiobutton( -text => $s, + -value => $s, + -variable => \$state, + -command => sub { + $be->configure( -state => $state ); } + )->pack( qw/-anchor w/ ); + } + $f->Button( -text => "Print value", -command => sub { + print "$var\n" } )->pack; + } +} diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/button.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/button.pl new file mode 100755 index 00000000000..4cc1b581678 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/button.pl @@ -0,0 +1,28 @@ +# button.pl + +use vars qw/$TOP/; + +sub button { + + # Create a top-level window that displays a bunch of buttons. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'If you click on any of the four buttons below, the background of the button area will change to the color indicated in the button. You can press Tab to move among the buttons, then press Space to invoke the current button.', + -title => 'Button Demonstration', + -iconname => 'button', + ); + + foreach my $color (qw/PeachPuff1 LightBlue1 SeaGreen2 Yellow1/) { + my $b = $TOP->Button( + -text => $color, + -width => 10, + -command => sub {$TOP->configure(-background => lc($color))}, + ); + $b->pack(qw/-side top -expand yes -pady 2/); + } + +} # end button + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/check.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/check.pl new file mode 100755 index 00000000000..a5f9a10c093 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/check.pl @@ -0,0 +1,44 @@ +# check.pl + +use vars qw/$TOP/; + +sub check { + + # Create a top-level window that displays a bunch of check buttons. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'Three checkbuttons are displayed below. If you click on a button, it will toggle the button\'s selection state and set a Perl variable to a value indicating the state of the checkbutton. Click the "See Variables" button to see the current values of the variables.', + -title => 'Checkbutton Demonstration', + -iconname => 'check', + ); + + my $var = $TOP->Button( + -text => 'See Variables', + -command => [\&see_vars, $TOP, [ + ['wipers', \$WIPERS], + ['brakes', \$BRAKES], + ['sober', \$SOBER], + ], + ], + ); + $var->pack(qw/-side bottom -expand 1/); + + my(@pl) = qw/-side top -pady 2 -anchor w/; + my $b1 = $TOP->Checkbutton( + -text => 'Wipers OK', + -variable => \$WIPERS, + -relief => 'flat')->pack(@pl); + my $b2 = $TOP->Checkbutton( + -text => 'Brakes OK', + -variable => \$BRAKES, + -relief => 'flat')->pack(@pl); + my $b3 = $TOP->Checkbutton( + -text => 'Driver Sober', + -variable => \$SOBER, + -relief => 'flat')->pack(@pl); + +} # end check + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/choosedir.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/choosedir.pl new file mode 100755 index 00000000000..5062afa0fad --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/choosedir.pl @@ -0,0 +1,39 @@ +# This demonstration script prompts the user to select a directory. + +use vars qw/$TOP/; + +sub choosedir { + my $demo = shift; + + $TOP = $MW->WidgetDemo + ( + -name => $demo, + -text => "Enter a directory name in the entry box or click on the \"Browse\" buttons to select a directory name using the directory selection dialog.", + -title => 'Choose Directory Demonstration', + -iconname => 'choosedir', + ); + { + my $f = $TOP->Frame; + my $lab = $f->Label(-text => "Select a directory to open: ", + -anchor => 'e'); + my $ent = $f->Entry(-width => 20); + my $but = $f->Button(-text => "Browse ...", + -command => sub { dirDialog($TOP, $ent)}); + $lab->pack(-side => 'left'); + $ent->pack(-side => 'left',-expand => 'yes', -fill => 'x'); + $but->pack(-side => 'left'); + $f->pack(-fill => 'x', -padx => '1c', -pady => 3); + } +} + +sub dirDialog { + my $w = shift; + my $ent = shift; + my $dir; + $dir = $w->chooseDirectory; + if (defined $dir and $dir ne '') { + $ent->delete(0, 'end'); + $ent->insert(0, $dir); + $ent->xview('end'); + } +} diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/clrpick.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/clrpick.pl new file mode 100755 index 00000000000..df9d3a72cd7 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/clrpick.pl @@ -0,0 +1,45 @@ +# clrpick.pl + +use Tk qw/catch/; +use subs qw/setColor setColor_helper/; +use vars qw/$TOP/; + +sub clrpick { + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'Press the buttons below to choose the foreground and background colors for the widgets in this window.', + -title => 'chooseColor Demo', + -iconname => 'chooseColor', + ); + + my(@pl) = qw/-side top -anchor c -pady 2m/; + my($back, $front); + $back = $TOP->Button(-text => 'Set background color ...')->pack(@pl); + $back->configure(-command => [\&setColor => $TOP, $back, '-background', + [-background, -highlightbackground]]); + $front = $TOP->Button(-text => 'Set foreground color ...')->pack(@pl); + $front->configure(-command => [\&setColor => $TOP, $front, '-foreground', + [-foreground]]); +} + +sub setColor { + my($top, $button, $name, $options) = @_; + my $initialColor = $button->cget($name); + my $color = $button->chooseColor(-title => "Choose a $name color", + -initialcolor => $initialColor); + setColor_helper $top, $options, $color if defined $color; +} + +sub setColor_helper { + my($widget, $options, $color) = @_; + foreach my $option (@$options) { + catch { + $widget->configure($option => $color); + } + } + foreach my $child ($widget->children) { + setColor_helper $child, $options, $color; + } +} + diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/colors.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/colors.pl new file mode 100755 index 00000000000..922225107c1 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/colors.pl @@ -0,0 +1,85 @@ +# colors.pl + +use vars qw/$TOP/; + +sub colors { + + # Create a top-level window containing a listbox showing a bunch of + # colors from the X color database. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the application\'s color palette will be set to match that color.', + -title => 'Listbox Demonstration (colors)', + -iconname => 'colors', + ); + + my $list = $TOP->Scrolled(qw/Listbox -width 20 -height 16 -setgrid 1 + -scrollbars e/); + $list->pack(qw/-side left -fill y/); + $list->focus; + + $list->bind('<Double-1>' => + sub { + $_[0]->setPalette($_[0]->get('active')); + }, + ); + + $list->insert(0, qw/gray60 gray70 gray80 gray85 gray90 +gray95 snow1 snow2 snow3 snow4 seashell1 seashell2 seashell3 seashell4 +AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 AntiqueWhite4 bisque1 +bisque2 bisque3 bisque4 PeachPuff1 PeachPuff2 PeachPuff3 PeachPuff4 +NavajoWhite1 NavajoWhite2 NavajoWhite3 NavajoWhite4 LemonChiffon1 +LemonChiffon2 LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 +cornsilk3 cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 +honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 LavenderBlush3 +LavenderBlush4 MistyRose1 MistyRose2 MistyRose3 MistyRose4 azure1 +azure2 azure3 azure4 SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 +RoyalBlue1 RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 +DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 SteelBlue2 +SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 DeepSkyBlue3 +DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 SkyBlue4 LightSkyBlue1 +LightSkyBlue2 LightSkyBlue3 LightSkyBlue4 SlateGray1 SlateGray2 +SlateGray3 SlateGray4 LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 +LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 LightBlue4 LightCyan1 +LightCyan2 LightCyan3 LightCyan4 PaleTurquoise1 PaleTurquoise2 +PaleTurquoise3 PaleTurquoise4 CadetBlue1 CadetBlue2 CadetBlue3 +CadetBlue4 turquoise1 turquoise2 turquoise3 turquoise4 cyan1 cyan2 +cyan3 cyan4 DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 +DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 aquamarine4 +DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 DarkSeaGreen4 SeaGreen1 +SeaGreen2 SeaGreen3 SeaGreen4 PaleGreen1 PaleGreen2 PaleGreen3 +PaleGreen4 SpringGreen1 SpringGreen2 SpringGreen3 SpringGreen4 green1 +green2 green3 green4 chartreuse1 chartreuse2 chartreuse3 chartreuse4 +OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 DarkOliveGreen1 +DarkOliveGreen2 DarkOliveGreen3 DarkOliveGreen4 khaki1 khaki2 khaki3 +khaki4 LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 LightGoldenrod4 +LightYellow1 LightYellow2 LightYellow3 LightYellow4 yellow1 yellow2 +yellow3 yellow4 gold1 gold2 gold3 gold4 goldenrod1 goldenrod2 +goldenrod3 goldenrod4 DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 +DarkGoldenrod4 RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 +IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 sienna4 +burlywood1 burlywood2 burlywood3 burlywood4 wheat1 wheat2 wheat3 +wheat4 tan1 tan2 tan3 tan4 chocolate1 chocolate2 chocolate3 chocolate4 +firebrick1 firebrick2 firebrick3 firebrick4 brown1 brown2 brown3 +brown4 salmon1 salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 +LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 DarkOrange1 +DarkOrange2 DarkOrange3 DarkOrange4 coral1 coral2 coral3 coral4 +tomato1 tomato2 tomato3 tomato4 OrangeRed1 OrangeRed2 OrangeRed3 +OrangeRed4 red1 red2 red3 red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 +HotPink1 HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 LightPink1 +LightPink2 LightPink3 LightPink4 PaleVioletRed1 PaleVioletRed2 +PaleVioletRed3 PaleVioletRed4 maroon1 maroon2 maroon3 maroon4 +VioletRed1 VioletRed2 VioletRed3 VioletRed4 magenta1 magenta2 magenta3 +magenta4 orchid1 orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 +MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 DarkOrchid1 +DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 purple2 purple3 purple4 +MediumPurple1 MediumPurple2 MediumPurple3 MediumPurple4 thistle1 +thistle2 thistle3 thistle4/); + + $list->activate(0); + +} # end colors + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/cscroll.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/cscroll.pl new file mode 100755 index 00000000000..e39e9caac56 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/cscroll.pl @@ -0,0 +1,86 @@ +# cscroll.pl + +use subs qw/cscroll_button cscroll_enter cscroll_leave/; +use vars qw/$TOP/; + +sub cscroll { + + # Create a top-level window containing a simple canvas that can be + # scrolled in two dimensions. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout.', + -title => 'Scrollable Canvas Demonstration', + -iconname => 'cscroll', + ); + + my $c = $TOP->Scrolled(qw/Canvas -relief sunken -borderwidth 2 + -scrollbars se -scrollregion/ => ['-10c', '-10c', '50c', '20c']); + $c->pack(qw/-expand yes -fill both/); + + my($bg, $i, $j, $x, $y) = ($c->configure(-background))[4]; + for ($i = 0; $i < 20; $i++) { + $x = -10 + 3 * $i; + $j = 0; + $y = -10; + while ($j < 10) { + $c->createRectangle("${x}c", "${y}c", + ($x+2).'c', ($y+2).'c', + -outline => 'black', -fill => $bg, -tags => 'rect'); + $c->createText(($x+1).'c', ($y+1).'c', + -text => "$i,$j", -anchor => 'center', -tags => 'text'); + $j++; + $y += 3; + } # whilend + } # forend + + my $old_fill = ''; + $c->bind('all', '<Any-Enter>' => [\&cscroll_enter, \$old_fill]); + $c->bind('all', '<Any-Leave>' => [\&cscroll_leave, \$old_fill]); + $c->bind('all', '<1>' => \&cscroll_button); + + $c->CanvasBind('<2>' => [ scanMark => Ev('x'), Ev('y') ]); + $c->CanvasBind('<B2-Motion>' => [ scanDragto => Ev('x'), Ev('y') ]); + +} # end cscroll + +sub cscroll_button { + + my($c) = @_; + + my ($id) = $c->find(qw/withtag current/); + $id++ if ($c->gettags('current'))[0] ne 'text'; + print STDOUT 'You buttoned at ', ($c->itemconfigure($id, -text))[4], "\n"; + +} # end cscroll_button + +sub cscroll_enter { + + my($c, $old_fill) = @_; + + my ($id) = $c->find(qw/withtag current/); + $id-- if ($c->gettags('current'))[0] eq 'text'; + $$old_fill = ($c->itemconfigure($id, -fill))[4]; + if ($c->depth > 1) { + $c->itemconfigure($id, -fill => 'SeaGreen1'); + } else { + $c->itemconfigure($id, -fill => 'black'); + $c->itemconfigure($id+1, -fill => 'white'); + } + +} # end cscroll_enter + +sub cscroll_leave { + + my($c, $old_fill) = @_; + + my ($id) = $c->find(qw/withtag current/); + $id-- if ($c->gettags('current'))[0] eq 'text'; + $c->itemconfigure($id, -fill => $$old_fill); + $c->itemconfigure($id+1, -fill => 'black'); + +} # end cscroll_leave + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ctext.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ctext.pl new file mode 100755 index 00000000000..9c2ca476379 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ctext.pl @@ -0,0 +1,170 @@ +# ctext.pl + +use subs qw/ctext_bs ctext_configure ctext_enter ctext_move ctext_press/; +use vars qw/$TOP/; + +sub ctext { + + # Create a window containing a canvas displaying a text string and + # allowing the string to be edited and re-anchored. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adijust the position of the text relative to its positioning point or change its justification. The text also supports the following simple bindings for editing: + 1. You can point, click, and type. + 2. You can also select with button 1. + 3. You can copy the selection to the mouse position with button 2. + 4. Backspace and Control+h delete the selection if there is one; + otherwise they delete the character just before the insertion cursor. + 5. Delete deletes the selection if there is one; otherwise it deletes + the character just after the insertion cursor.', qw/-wraplength 5i/], + -title => 'Canvas Text Demonstration', + -iconname => 'ctext', + ); + + my $c = $TOP->Canvas(qw/-relief flat -bd 0 -width 500 -height 350/); + $c->pack(qw/-side top -expand yes -fill both/); + + $c->create(qw/rectangle 245 195 255 205 -outline black -fill red/); + + # First, create the text item and give it bindings so it can be edited. + + $c->addtag(qw/text withtag/, + $c->create('text', 250, 200, + -text => 'This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)."', + qw/-width 440 -anchor n -justify left + -font -*-Helvetica-Medium-R-Normal--*-240-*-*-*-*-*-*/ + ), + ); + $c->bind(qw/text <1>/ => \&ctext_press); + $c->bind(qw/text <B1-Motion>/ => \&ctext_move); + $c->bind(qw/text <Shift-1>/ => sub { + my($c) = @_; + my $e = $c->XEvent; + my($x, $y) = ($e->x, $e->y); + $c->select(qw/adjust current/, "\@$x,$y"); + }); + $c->bind(qw/text <Shift-B1-Motion>/ => \&ctext_move); + $c->bind(qw/text <KeyPress>/ => sub { + my($c) = @_; + my $e = $c->XEvent; + my $A = $e->A; + $c->insert(qw/text insert/, "$A"); + }); + $c->bind(qw/text <Return>/ => sub { + my($c) = @_; + $c->insert(qw/text insert/, "\\n"); + }); + $c->bind(qw/text <Control-h>/ => \&ctext_bs); + $c->bind(qw/text <BackSpace>/ => \&ctext_bs); + $c->bind(qw/text <Delete>/ => sub { + my($c) = @_; + eval {local $SIG{__DIE__}; $c->dchars(qw/text sel.first sel.last/)}; + $c->dchars('text', 'insert'); + }); + $c->bind(qw/text <2>/ => sub { + my($c) = @_; + my $e = $c->XEvent; + $c->insert('text', $e->xy, $MW->SelectionGet); + }); + + # Next, create some items that allow the text's anchor position to + # be edited. + + my($x, $y, $color) = (50, 50, 'LightSkyBlue1'); + ctext_configure $c, $x, $y, -anchor => 'se', $color; + ctext_configure $c, $x+30, $y, -anchor => 's', $color; + ctext_configure $c, $x+60, $y, -anchor => 'sw', $color; + ctext_configure $c, $x, $y+30, -anchor => 'e', $color; + ctext_configure $c, $x+30, $y+30, -anchor => 'center', $color; + ctext_configure $c, $x+60, $y+30, -anchor => 'w', $color; + ctext_configure $c, $x, $y+60, -anchor => 'ne', $color; + ctext_configure $c, $x+30, $y+60, -anchor => 'n', $color; + ctext_configure $c, $x+60, $y+60, -anchor => 'nw', $color; + my $item = $c->create('rectangle', $x+40, $y+40, $x+50, $y+50, + qw/-outline black -fill red/); + $c->bind($item, '<1>' => sub { + shift->itemconfigure(qw/text -anchor center/); + }); + $c->create('text', $x+45, $y-5, -text => 'Text Position', qw/-anchor s + -font -*-times-medium-r-normal--*-240-*-*-*-*-*-* + -fill brown/); + + # Lastly, create some items that allow the text's justification + # to be changed. + + $x = 350; $y = 50; $color = 'SeaGreen2'; + ctext_configure $c, $x, $y, -justify => 'left', $color; + ctext_configure $c, $x+30, $y, -justify => 'center', $color; + ctext_configure $c, $x+60, $y, -justify => 'right', $color; + $c->create('text', $x+45, $y-5, qw/-text Justification -anchor s + -font -*-times-medium-r-normal--*-240-*-*-*-*-*-* + -fill brown/); + + my $config_fill = ''; + $c->bind(qw/config <Enter>/ => [\&ctext_enter, \$config_fill]); + $c->bind(qw/config <Leave>/ => + sub {$c->itemconfigure('current', -fill => $config_fill)} + ); + +} # end ctext + +sub ctext_bs { + + my($c) = @_; + + eval {local $SIG{__DIE__}; $c->dchars(qw/text sel.first sel.last/)}; + my $char = $c->index(qw/text insert/) - 1; + $c->dchars('text', $char) if $char >= 0; + +} # end ctext_bs + +sub ctext_configure { + + my($w, $x, $y, $option, $value, $color) = @_; + + my $item = $w->create('rectangle', $x, $y, $x+30, $y+30, + -outline => 'black', -fill => $color, -width => 1); + $w->bind($item, '<1>', + sub {$w->itemconfigure('text', $option => $value)} + ); + $w->addtag(qw/config withtag/, $item); + +} # end ctext_configure + +sub ctext_enter { + + my($w, $config_fill) = @_; + + $$config_fill = ($w->itemconfigure('current', -fill))[4]; + $w->itemconfigure(qw/current -fill black/); + +} # end ctext_enter + +sub ctext_move { + + my($w) = @_; + my $e = $w->XEvent; + + my($x, $y) = ($e->x, $e->y); + $w->select(qw/to current/, "\@$x,$y"); + +} # end ctext_move + +sub ctext_press { + + my($w) = @_; + my $e = $w->XEvent; + + my($x, $y) = ($e->x, $e->y); + $w->icursor('current', "\@$x,$y"); + $w->focus('current'); + $w->CanvasFocus; + $w->select(qw/from current/, "\@$x,$y"); + +} # end ctext_press + +1; + + diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog1.pl new file mode 100755 index 00000000000..9c98bdfca22 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog1.pl @@ -0,0 +1,33 @@ +# dialog1.pl + +use subs qw/see_code/; +use vars qw/$DIALOG1/; + +sub dialog1 { + + my($demo) = @_; + + my($ok, $can, $see) = ('OK', 'Cancel', 'See Code'); + if (not Exists($DIALOG1)) { + $DIALOG1 = $MW->Dialog( + -title => 'Dialog with local grab', + -text => '', + -bitmap => 'info', + -default_button => $ok, + -buttons => [$ok, $can, $see], + ); + $DIALOG1->configure( + -wraplength => '4i', + -text => 'This is a modal dialog box. It uses Tk\'s "grab" command to create a "local grab" on the dialog box. The grab prevents any pointer-related events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications.', + ); + } + + my $button = $DIALOG1->Show; + + print "You pressed OK\n" if $button eq $ok; + print "You pressed Cancel\n" if $button eq $can; + see_code 'dialog1' if $button eq $see; + +} # end dialog1 + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog2.pl new file mode 100755 index 00000000000..15b2102edcd --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dialog2.pl @@ -0,0 +1,33 @@ +# dialog2.pl + +use subs qw/see_code/; +use vars qw/$DIALOG2/; + +sub dialog2 { + + my($demo) = @_; + + my($ok, $can, $see) = ('OK', 'Cancel', 'See Code'); + if (not Exists($DIALOG2)) { + $DIALOG2 = $MW->Dialog( + -title => 'Dialog with global grab', + -text => '', + -bitmap => 'info', + -default_button => $ok, + -buttons => [$ok, $can, $see], + ); + $DIALOG2->configure( + -wraplength => '4i', + -text => 'This dialog box uses a global grab, so it prevents you from interacting with anything on your display until you invoke one of the buttons below. Global grabs are almost always a bad idea; don\'t use them unless you\'re truly desperate.', + ); + } + + my $button = $DIALOG2->Show('-global'); + + print "You pressed OK\n" if $button eq $ok; + print "You pressed Cancel\n" if $button eq $can; + see_code 'dialog2' if $button eq $see; + +} # end dialog2 + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dirtree.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dirtree.pl new file mode 100755 index 00000000000..0cf91417a56 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/dirtree.pl @@ -0,0 +1,7 @@ +# DirTree, display directory tree. + +use Tk; +use Tk::DirTree; +my $top = MainWindow->new; +my $dl = $top->Scrolled('DirTree')->pack(-expand => 1 , -fill => 'both'); +MainLoop; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry1.pl new file mode 100755 index 00000000000..6250df5f4d5 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry1.pl @@ -0,0 +1,28 @@ +# entry1.pl + +use vars qw/$TOP/; + +sub entry1 { + + # Create a top-level window that displays a bunch of entries. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed.', qw/-wraplength 5i/], + -title => 'Entry Demonstration (no scrollbars)', + -iconname => 'entry1', + ); + + my(@relief) = qw/-relief sunken/; + my(@pl) = qw/-side top -padx 10 -pady 5 -fill x/; + my $e1 = $TOP->Entry(@relief)->pack(@pl); + my $e2 = $TOP->Entry(@relief)->pack(@pl); + my $e3 = $TOP->Entry(@relief)->pack(@pl); + + $e1->insert(0, 'Initial value'); + $e2->insert('end', 'This entry contains a long value, much too long to fit in the window at one time, so long in fact that you\'ll have to scan or scroll to see the end.'); + +} # end entry1 + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry2.pl new file mode 100755 index 00000000000..4f3c85e3454 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry2.pl @@ -0,0 +1,33 @@ +# entry2.pl + +use vars qw/$TOP/; + +sub entry2 { + + # Create a top-level window that displays a bunch of entries with + # scrollbars. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed.', -wraplength => '5i'], + -title => 'Entry Demonstration (with scrollbars)', + -iconname => 'entry2', + ); + + my(@pl) = qw/-side top -fill x/; + my(@scrolled_attributes) = qw/Entry -relief sunken -scrollbars s/; + my(@spacer_attributes) = qw/-width 20 -height 10/; + + my $e1 = $TOP->Scrolled(@scrolled_attributes)->pack(@pl); + my $spacer1 = $TOP->Frame(@spacer_attributes)->pack(@pl); + my $e2 = $TOP->Scrolled(@scrolled_attributes)->pack(@pl); + my $spacer2 = $TOP->Frame(@spacer_attributes)->pack(@pl); + my $e3 = $TOP->Scrolled(@scrolled_attributes)->pack(@pl); + + $e1->insert(0, 'Initial value'); + $e2->insert('end', 'This entry contains a long value, much too long to fit in the window at one time, so long in fact that you\'ll have to scan or scroll to see the end.'); + +} # end entry2 + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry3.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry3.pl new file mode 100755 index 00000000000..b296fbb0353 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/entry3.pl @@ -0,0 +1,199 @@ +# entry3.pl + +use vars qw/$TOP/; + +sub entry3 { + + # This demonstration script creates several entry widgets whose + # permitted input is constrained in some way. It also shows off a + # password entry. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'Four different entries are displayed below. You can add characters by pointing, clicking and typing, though each is constrained in what it will accept. The first only accepts integers or the empty string (checking when focus leaves it) and will flash to indicate any problem. The second only accepts strings with fewer than ten characters and sounds the bell when an attempt to go over the limit is made. The third accepts US phone numbers, mapping letters to their digit equivalent and sounding the bell on encountering an illegal character or if trying to type over a character that is not a digit. The fourth is a password field that accepts up to eight characters (silently ignoring further ones), and displaying them as asterisk characters.', + -title => 'Constrained Entry Demonstration', + -iconname => 'entry3', + ); + + + my $lf1 = $TOP->Labelframe(-text => 'Integer Entry'); + my $e1; + $e1 = $lf1->Entry( + -validate => 'focus', + -validatecommand => sub { + my ($proposed, $changes, $current, $index, $type) = @_; + return not $proposed =~ m/[^\d]/g; + }, + ); + $e1->configure( + -invalidcommand => + [\&entry3_flash, $e1, $e1->cget(-fg), $e1->cget(-bg)], + ); + $e1->pack(qw/-fill x -expand 1 -padx 1m -pady 1m/); + + my $lf2 = $TOP->Labelframe(-text => 'Length-Constrained Entry'); + my $e2 = $lf2->Entry( + -validate => 'key', + -invalidcommand => sub {$TOP->bell}, + -validatecommand => sub { + my ($proposed, $changes, $current, $index, $type) = @_; + return length($proposed) < 10 ? 1 : 0; + }, + ); + $e2->pack(qw/-fill x -expand 1 -padx 1m -pady 1m/); + + # phone number entry + # + # Note that the source to this is quite a bit longer as the behaviour + # demonstrated is a lot more ambitious than with the others. + # + # Mapping from alphabetic characters to numbers. This is probably + # wrong, but it is the only mapping I have; the UK doesn't really go + # for associating letters with digits for some reason. + + my %phone_letters = qw/abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9/; + my %l2n; # letter to number mapping hash + + while (my ($k, $v) = each %phone_letters) { + map {$l2n{$_} = $v} split '', $k; + } + + my $lf3 = $TOP->Labelframe(-text => 'US Phone-Number Entry'); + my $e3_var = '1-(000)-000-0000'; + my $e3; + $e3 = $lf3->Entry( + -validate => 'key', + -invalidcommand => sub {$TOP->bell}, + -textvariable => \$e3_var, + ); + $e3->configure( + -validatecommand => [\&entry3_validate_phone, $e3, \%l2n], + ); + $e3->pack(qw/-fill x -expand 1 -padx 1m -pady 1m/); + # Click to focus goes to the first editable character... + $e3->bind('<FocusIn>' => sub { + my $e = shift; + if ($Tk::event->d ne "NotifyAncestor") { + $e->icursor(3); + $e->afterIdle(sub {$e->selectionClear}); + } + }); + $e3->bind('<Left>' => \&entry3_phone_left); + $e3->bind('<Right>' => \&entry3_phone_right); + + my $lf4 = $TOP->Labelframe(-text => 'Password Entry'); + my $e4 = $lf4->Entry( + -validate => 'key', + -show => '*', + -validatecommand => sub { + my ($proposed, $changes, $current, $index, $type) = @_; + return length($proposed) <= 8 ? 1 : 0; + }, + ); + $e4->pack(qw/-fill x -expand 1 -padx 1m -pady 1m/); + + my $f = $TOP->Frame; + $f->lower; + $lf1->grid($lf2, -in => $f, qw/-padx 3m -pady 1m -sticky ew/); + $lf3->grid($lf4, -in => $f, qw/-padx 3m -pady 1m -sticky ew/); + $f->gridColumnconfigure([0, 1], -uniform => 1); + $f->pack(qw/-fill both -expand 1/); + +} # end entry3 + +sub entry3_flash { + my ($w, $fg, $bg) = @_; + $w->focusForce; + $w->{count} = 9 unless defined $w->{count}; + if ($w->{count} < 1) { + $w->configure(-foreground => $fg, -background => $bg); + $w->{count} = 9; + } else { + if ($w->{count} % 2) { + $w->configure(-foreground => $bg, -background => $fg); + } else { + $w->configure(-foreground => $fg, -background => $bg); + } + $w->{count}--; + $w->after(200 => [\&entry3_flash, $w, $fg, $bg]); + } +} # end entry3_flash + +sub entry3_phone_left { + + # Skip over fixed characters in a phone-number string when moving left. + + my $e = shift; + my $index = $e->index('insert'); + if ($index == 8) { + # Skip back two extra characters + $index -= 2; + $e->icursor($index); + } elsif ($index == 7 or $index == 12) { + # Skip back one extra character + $index -= 1; + $e->icursor($index); + } elsif ($index <= 3) { + # Can't move any further + $e->bell; + #return -code break + $e->break; + } + +} # end entry3_phone_left + +sub entry3_phone_right { + + # Skip over fixed characters in a phone-number string when moving right. + + my ($e, $add) = @_; + + $add = 0 unless defined $add; + my $index = $e->index('insert'); + if ($index + $add == 5) { + # Skip forward two extra characters + $index += 2; + $e->icursor($index); + } elsif ($index + $add == 6 or $index + $add == 10) { + # Skip forward one extra character + $index++; + $e->icursor($index); + } elsif ($index + $add == 15 and not $add) { + # Can't move any further + $e->bell; + #return -code break + $e->break; + } + +} # end entry3_phone_right + +sub entry3_validate_phone { + + # Checks that the replacement (mapped to a digit) of the given + # character in an entry widget at the given position will leave a + # valid phone number in the widget. + + my ($w, $l2n_ref, $proposed, $changes, $current, $index, $type) = @_; + + return 1 if $index == -1; + my $val = $w->cget(-validate); + $w->afterIdle(sub { + $w->configure( + -validate => $val, + -invalidcommand => sub {$w->bell}, + ); + }); + if (not ($index < 3 or $index == 6 or $index == 7 or $index == 11 or + $index > 15) and $changes =~ m/[0-9A-Z]/i) { + $w->delete($index); + $changes =~ s/$_/$l2n_ref->{$_}/ig foreach (keys %$l2n_ref); + $w->insert($index, $changes); + $w->afterIdle([\&entry3_phone_right, $w, -1]); + return 1; + } + return 0; + +} # end entry3_validate_phone; + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/filebox.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/filebox.pl new file mode 100755 index 00000000000..0d1b9737c01 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/filebox.pl @@ -0,0 +1,106 @@ +# filebox.tcl -- +# +# This demonstration script prompts the user to select a file. +# +# SCCS: @(#) filebox.tcl 1.3 97/03/02 16:22:36 + +use vars qw/$TOP/; + +sub filebox { + my $demo = shift; + + $TOP = $MW->WidgetDemo + ( + -name => $demo, + -text => "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog.", + -title => 'File box Demonstration', + -iconname => 'filebox', + ); + foreach my $i (qw(open save)) { + my $f = $TOP->Frame; + my $lab = $f->Label(-text => "Select a file to $i: ", + -anchor => 'e'); + my $ent = $f->Entry(-width => 20); + my $but = $f->Button(-text => "Browse ...", + -command => sub { fileDialog($TOP, $ent, $i)}); + $lab->pack(-side => 'left'); + $ent->pack(-side => 'left',-expand => 'yes', -fill => 'x'); + $but->pack(-side => 'left'); + $f->pack(-fill => 'x', -padx => '1c', -pady => 3); + } + + my $cbf = $TOP->Frame->pack(-fill => 'x', -padx => '1c', -pady => 3); + my $fd; + $cbf->Radiobutton + (-text => 'FileSelect', + -variable => \$fd, + -value => 'FileSelect', + -command => sub { local($^W) = 0; + require Tk::FileSelect; + Tk::FileSelect->import('as_default'); + _removeCachedFileDialogs(); + })->pack(-side => 'left'); + my $fdb = $cbf->Radiobutton + (-text => 'FBox', + -variable => \$fd, + -value => 'FBox', + -command => sub { local($^W) = 0; + require Tk::FBox; + Tk::FBox->import('as_default'); + _removeCachedFileDialogs(); + })->pack(-side => 'left'); + $fdb->invoke; + +# XXX Motif style file box not implemented +# unless (compare($tcl_platform{'platform'},'unix')) +# { +# $w->{'.strict'} = $w->Checkbutton('Name','strict','-text',"Use Motif Style Dialog",'-variable','tk_strictMotif','-onvalue',1,'-offvalue',0); +# $w->{'.strict'}->pack('-anchor','c'); +# } +} + +sub fileDialog { + my $w = shift; + my $ent = shift; + my $operation = shift; + my $types; + my $file; + # Type names Extension(s) Mac File Type(s) + # + #--------------------------------------------------------- + @types = + (["Text files", [qw/.txt .doc/]], + ["Text files", '', 'TEXT'], + ["Perl Scripts", '.pl', 'TEXT'], + ["C Source Files", ['.c', '.h']], + ["All Source Files", [qw/.tcl .c .h/]], + ["Image Files", '.gif'], + ["Image Files", ['.jpeg', '.jpg']], + ["Image Files", '', [qw/GIFF JPEG/]], + ["All files", '*'] + ); + if ($operation eq 'open') { + $file = $w->getOpenFile(-filetypes => \@types); + } else { + $file = $w->getSaveFile(-filetypes => \@types, + -initialfile => 'Untitled', + -defaultextension => '.txt'); + } + if (defined $file and $file ne '') { + $ent->delete(0, 'end'); + $ent->insert(0, $file); + $ent->xview('end'); + } +} + +sub _removeCachedFileDialogs { + my $mw = $TOP->MainWindow; + my $remove = sub { + my $t = shift; + return if (!UNIVERSAL::isa($t, "Tk::Toplevel")); + delete $t->{'tk_getOpenFile'}; + delete $t->{'tk_getSaveFile'}; + }; + $remove->($mw); + $mw->Walk($remove); +} diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/floor.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/floor.pl new file mode 100755 index 00000000000..5fa5be1ead2 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/floor.pl @@ -0,0 +1,1324 @@ +# floor.pl + +use Tk::Trace; +use subs qw/floor_bg1 floor_bg2 floor_bg3 floor_display floor_fg1 floor_fg2 + floor_fg3 floor_room_changed/; +use vars qw/$TOP/; + +sub floor { + + # Create a top-level window containing a Canvas that displays the + # floorplan for DEC's Western Research Laboratory. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['This window contains a canvas widget showing the floorplan of Digital Equipment Corporation\'s Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the "Room:" entry. You can also type a room number in the entry and the room will light up.', qw/-wraplength 8i/], + -title => 'Floorplan Canvas Demonstration', + -iconname => 'floor', + ); + + my $c = $TOP->Scrolled(qw/Canvas -width 900 -height 500 -relief sunken + -borderwidth 2 -scrollbars se/); + $c->pack(qw/-expand yes -fill both/); + + # Create an Entry for displaying and typing in current room. + + $floor::current_room = ''; + my $c_entry = $c->Entry(qw/-width 10 -relief sunken -borderwidth 2 + -textvariable/ => \$floor::current_room); + + # Choose colors, then fill in the floorplan. + + my %cinfo; # color information hash + if ($TOP->depth > 1) { + $cinfo{'floor_bg1'} = '#a9c1da'; + $cinfo{outline1} = '#77889a'; + $cinfo{'floor_bg2'} = '#9ab0c6'; + $cinfo{outline2} = '#687786'; + $cinfo{'floor_bg3'} = '#8ba0b3'; + $cinfo{outline3} = '#596673'; + $cinfo{offices} = 'Black'; + $cinfo{active} = '#c4d1df'; + } else { + $cinfo{'floor_bg1'} = 'white'; + $cinfo{outline1} = 'black'; + $cinfo{'floor_bg2'} = 'white'; + $cinfo{outline2} = 'black'; + $cinfo{'floor_bg3'} = 'white'; + $cinfo{outline3} = 'black'; + $cinfo{offices} = 'Black'; + $cinfo{active} = 'black'; + } + + my %floor_labels = (); + my %floor_items = (); + my $active_floor = 0; + floor_display $c->Subwidget('canvas'), 3, \%floor_labels, \%floor_items, + \%cinfo, \$active_floor, $c_entry; + + # Set up event bindings for the Canvas. + + my $floor_number; + for $floor_number (1..3) { + $c->bind("floor${floor_number}", '<1>' => + [\&floor_display, $floor_number, \%floor_labels, \%floor_items, + \%cinfo, \$active_floor, $c_entry], + ); + } + $c->bind('room', '<Enter>' => sub { + my($c) = @_; + my $id = $c->find('withtag' => 'current'); + $id = $id->[0] if ref($id) eq 'ARRAY'; + $floor::current_room = $floor_labels{$id} if defined $id; + $c->idletasks; + }); + $c->bind('room', '<Leave>' => sub {$floor::current_room = ''}); + $c->CanvasBind('<2>' => sub { + my($c) = @_; + my $e = $c->XEvent; + $c->scanMark($e->x, $e->y); + }); + $c->CanvasBind('<B2-Motion>' => sub { + my($c) = @_; + my $e = $c->XEvent; + $c->scanDragto($e->x, $e->y); + }); + $c->CanvasBind('<Enter>', => [sub {shift; shift->focus}, $c_entry]); + + $c->traceVariable(\$floor::current_room, 'w' => + [sub { + my($index, $value, $op, $floor_items, $cinfo) = @_; + return if $op eq 'u'; + $floor_current_room = $value; + &floor_room_changed($c->Subwidget('canvas'), $floor_items, $cinfo); + $value; # always return variable's new value + }, \%floor_items, \%cinfo], + ); + +} # floor + +sub floor_display { + + # The following procedure recreates the floorplan display in the + # Canvas given by "w". The floor given by "active" (1, 2, or 3) is + # displayed on top, with office structure visible. (Used as a callback + # and a normal function.) + + my($c, $active, $floor_labels, $floor_items, $cinfo, $active_floor, + $c_entry) = @_; + + return if $$active_floor eq $active; + + $c->delete('all'); + $$active_floor = $active; + + # First go through the three floors, displaying the backgrounds for + # each floor. + + floor_bg1 $c, $cinfo->{'floor_bg1'}, $cinfo->{outline1}; + floor_bg2 $c, $cinfo->{'floor_bg2'}, $cinfo->{outline2}; + floor_bg3 $c, $cinfo->{'floor_bg3'}, $cinfo->{outline3}; + + # Raise the background for the active floor so that it's on top. + + $c->raise("floor${active}"); + + # Create a dummy item just to mark this point in the display list, so + # we can insert highlights here. + + $c->create('rectangle', 0, 100, 1, 101, -fill => undef, -outline => undef, + -tags => 'marker'); + + # Add the walls and labels for the active floor, along with transparent + # polygons that define the rooms on the floor. Make sure that the room + # polygons are on top. + + my $cmd = "floor_fg${active}"; + { + no strict qw(refs); + &$cmd($c, $cinfo->{offices}, $floor_labels, $floor_items); + } + $c->raise('room'); + + # Offset the floors diagonally from each other. + + $c->move(qw(floor1 2c 2c)); + $c->move(qw(floor2 1c 1c)); + + # Create items for the room entry and its label. + + $c->create('window', 600, 100, -anchor => 'w', -window => $c_entry); + $c->create('text', 600, 100, -anchor => 'e', -text => 'Room: '); + $c->configure(-scrollregion => [$c->bbox('all')]); + +} # end floor_display + + +sub floor_room_changed { + + # Whenever the current_room variable changes, this procedure highlights + # the current room and unhighlights any previous room. + + my($w, $floor_items, $cinfo) = @_; + + $w->delete('highlight'); + my $item = $floor_items->{$floor::current_room}; + return if not defined $item; + my(@c) = $w->coords($item); + if ($c[0]) { + $w->raise( + $w->create('polygon', @c, + -fill => $cinfo->{active}, + -tags => 'highlight', + ), + 'marker'); + } # ifend we have coordinates + +} # end floor_room_changed + +# The following procedures are invoked to instantiate various portions of +# the building floorplan. The bodies of these procedures were generated +# automatically from database files describing the building. + + +sub floor_bg1 { + + my ($w, $fill, $outline) = @_; + + $w->create('poly', qw(347 80 349 82 351 84 353 85 363 92 375 99 386 104 386 129 398 129 398 162 484 162 484 129 559 129 559 + 133 725 133 725 129 802 129 802 389 644 389 644 391 559 391 559 327 508 327 508 311 484 311 484 278 395 278 395 288 400 + 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 + 338 332 342 331 347 332 351 334 354 336 357 341 359 340 360 335 363 331 365 326 366 304 366 304 355 258 355 258 387 60 + 387 60 391 0 391 0 337 3 337 3 114 8 114 8 25 30 25 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 + 68 220 34 221 22 223 17 227 13 231 8 236 4 242 2 246 0 260 0 283 1 300 5 321 14 335 22 348 25 365 29 363 39 358 48 352 + 56 337 70 344 76 347 80), -tags => ['floor1', 'bg'], -fill => $fill); + + $w->create('line', qw(386 129 398 129), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(258 355 258 387), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(60 387 60 391), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(0 337 0 391), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(60 391 0 391), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(3 114 3 337), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(258 387 60 387), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(484 162 398 162), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(398 162 398 129), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(484 278 484 311), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(484 311 508 311), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(508 327 508 311), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(559 327 508 327), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(644 391 559 391), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(644 389 644 391), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(559 129 484 129), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(484 162 484 129), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(725 133 559 133), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(559 129 559 133), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(725 129 802 129), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(802 389 802 129), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(3 337 0 337), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(559 391 559 327), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(802 389 644 389), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(725 133 725 129), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(8 25 8 114), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(8 114 3 114), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(30 25 8 25), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(484 278 395 278), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(30 25 30 5), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(93 5 30 5), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(98 5 93 5), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(104 7 98 5), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(110 10 104 7), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(116 16 110 10), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(119 20 116 16), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(122 28 119 20), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(123 32 122 28), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(123 68 123 32), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(220 68 123 68), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(386 129 386 104), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(386 104 375 99), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(375 99 363 92), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(353 85 363 92), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(220 68 220 34), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(337 70 352 56), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(352 56 358 48), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(358 48 363 39), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(363 39 365 29), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(365 29 348 25), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(348 25 335 22), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(335 22 321 14), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(321 14 300 5), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(300 5 283 1), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(283 1 260 0), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(260 0 246 0), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(246 0 242 2), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(242 2 236 4), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(236 4 231 8), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(231 8 227 13), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(223 17 227 13), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(221 22 223 17), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(220 34 221 22), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(340 360 335 363), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(335 363 331 365), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(331 365 326 366), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(326 366 304 366), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(304 355 304 366), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(395 288 400 288), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(404 288 400 288), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(409 290 404 288), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(413 292 409 290), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(418 297 413 292), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(421 302 418 297), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(422 309 421 302), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(421 318 422 309), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(421 318 417 325), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(417 325 411 330), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(411 330 405 332), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(405 332 397 333), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(397 333 344 333), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(344 333 340 334), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(340 334 336 336), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(336 336 335 338), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(335 338 332 342), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(331 347 332 342), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(332 351 331 347), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(334 354 332 351), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(336 357 334 354), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(341 359 336 357), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(341 359 340 360), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(395 288 395 278), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(304 355 258 355), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(347 80 344 76), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(344 76 337 70), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(349 82 347 80), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(351 84 349 82), -fill => $outline, -tags => ['floor1', 'bg']); + $w->create('line', qw(353 85 351 84), -fill => $outline, -tags => ['floor1', 'bg']); + +} # end floor_bg1 + +sub floor_bg2 { + + my ($w, $fill, $outline) = @_; + + $w->create('poly', qw(559 129 484 129 484 162 398 162 398 129 315 129 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0 + 339 0 391 60 391 60 387 258 387 258 329 350 329 350 311 395 311 395 280 484 280 484 311 508 311 508 327 558 327 558 391 + 644 391 644 367 802 367 802 129 725 129 725 133 559 133 559 129), -tags => ['floor2', 'bg'], -fill => $fill); + $w->create('line', qw(350 311 350 329), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(398 129 398 162), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(802 367 802 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(802 129 725 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(725 133 725 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(559 129 559 133), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(559 133 725 133), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(484 162 484 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(559 129 484 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(802 367 644 367), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(644 367 644 391), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(644 391 558 391), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(558 327 558 391), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(558 327 508 327), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(508 327 508 311), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(484 311 508 311), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(484 280 484 311), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(398 162 484 162), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(484 280 395 280), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(395 280 395 311), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(258 387 60 387), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(3 133 3 339), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(3 339 0 339), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(60 391 0 391), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(0 339 0 391), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(60 387 60 391), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(258 329 258 387), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(350 329 258 329), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(395 311 350 311), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(398 129 315 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(176 133 315 133), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(176 129 96 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(3 133 96 133), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(315 133 315 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(176 133 176 129), -fill => $outline, -tags => ['floor2', 'bg']); + $w->create('line', qw(96 133 96 129), -fill => $outline, -tags => ['floor2', 'bg']); + +} # end floor_bg2 + +sub floor_bg3 { + + my ($w, $fill, $outline) = @_; + + $w->create('poly', qw(159 300 107 300 107 248 159 248 159 129 96 129 96 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370 + 159 300), -tags => ['floor3', 'bg'], -fill => $fill); + $w->create('poly', qw(258 370 258 329 350 329 350 311 399 311 399 129 315 129 315 133 176 133 176 129 159 129 159 370 258 + 370), -tags =>['floor3', 'bg'], -fill => $fill); + $w->create('line', qw(96 133 96 129), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(176 129 96 129), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(176 129 176 133), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(315 133 176 133), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(315 133 315 129), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(399 129 315 129), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(399 311 399 129), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(399 311 350 311), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(350 329 350 311), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(350 329 258 329), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(258 370 258 329), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(60 370 258 370), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(60 370 60 391), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(60 391 0 391), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(0 391 0 331), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(21 331 0 331), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(21 331 21 133), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(96 133 21 133), -fill => $outline, -tags => ['floor3', 'bg']); + $w->create('line', qw(107 300 159 300 159 248 107 248 107 300), -fill => $outline, -tags => ['floor3', 'bg']); + +} # end floor_bg3 + +sub floor_fg1 { + + my($w, $color, $fl, $fi) = @_; + + my($i); + $i = $w->create('polygon', qw(375 246 375 172 341 172 341 246), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 101; + $fi->{101} = $i; + $w->create('text', qw(358 209), -text => '101', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(307 240 339 240 339 206 307 206), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'Pub Lift1'; + $fi->{'Pub Lift1'} = $i; + $w->create('text', qw(323 223), -text => 'Pub Lift1', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(339 205 307 205 307 171 339 171), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'Priv Lift1'; + $fi->{'Priv Lift1'} = $i; + $w->create('text', qw(323 188), -text => 'Priv Lift1', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(42 389 42 337 1 337 1 389), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 110; + $fi->{110} = $i; + $w->create('text', qw(21.5 363), -text => '110', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(59 389 59 385 90 385 90 337 44 337 44 389), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 109; + $fi->{109} = $i; + $w->create('text', qw(67 363), -text => '109', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(51 300 51 253 6 253 6 300), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 111; + $fi->{111} = $i; + $w->create('text', qw(28.5 276.5), -text => '111', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(98 248 98 309 79 309 79 248), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = '117B'; + $fi->{'117B'} = $i; + $w->create('text', qw(88.5 278.5), -text => '117B', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(51 251 51 204 6 204 6 251), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 112; + $fi->{112} = $i; + $w->create('text', qw(28.5 227.5), -text => '112', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(6 156 51 156 51 203 6 203), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 113; + $fi->{113} = $i; + $w->create('text', qw(28.5 179.5), -text => '113', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(85 169 79 169 79 192 85 192), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = '117A'; + $fi->{'117A'} = $i; + $w->create('text', qw(82 180.5), -text => '117A', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(77 302 77 168 53 168 53 302), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 117; + $fi->{117} = $i; + $w->create('text', qw(65 235), -text => '117', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(51 155 51 115 6 115 6 155), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 114; + $fi->{114} = $i; + $w->create('text', qw(28.5 135), -text => '114', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(95 115 53 115 53 168 95 168), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 115; + $fi->{115} = $i; + $w->create('text', qw(74 141.5), -text => '115', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(87 113 87 27 10 27 10 113), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 116; + $fi->{116} = $i; + $w->create('text', qw(48.5 70), -text => '116', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(89 91 128 91 128 113 89 113), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 118; + $fi->{118} = $i; + $w->create('text', qw(108.5 102), -text => '118', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 120; + $fi->{120} = $i; + $w->create('text', qw(189.5 111.5), -text => '120', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 122; + $fi->{122} = $i; + $w->create('text', qw(131 207.5), -text => '122', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(138 169 154 169 154 191 138 191), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 121; + $fi->{121} = $i; + $w->create('text', qw(146 180), -text => '121', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(99 300 126 300 126 309 99 309), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = '106A'; + $fi->{'106A'} = $i; + $w->create('text', qw(112.5 304.5), -text => '106A', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(128 299 128 309 150 309 150 248 99 248 99 299), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 105; + $fi->{105} = $i; + $w->create('text', qw(124.5 278.5), -text => '105', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(174 309 174 300 152 300 152 309), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = '106B'; + $fi->{'106B'} = $i; + $w->create('text', qw(163 304.5), -text => '106B', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(176 299 176 309 216 309 216 248 152 248 152 299), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 104; + $fi->{104} = $i; + $w->create('text', qw(184 278.5), -text => '104', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(138 385 138 337 91 337 91 385), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 108; + $fi->{108} = $i; + $w->create('text', qw(114.5 361), -text => '108', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(256 337 140 337 140 385 256 385), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 107; + $fi->{107} = $i; + $w->create('text', qw(198 361), -text => '107', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(300 353 300 329 260 329 260 353), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'Smoking'; + $fi->{Smoking} = $i; + $w->create('text', qw(280 341), -text => 'Smoking', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(314 135 314 170 306 170 306 246 177 246 177 135), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 123; + $fi->{123} = $i; + $w->create('text', qw(245.5 190.5), -text => '123', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(217 248 301 248 301 326 257 326 257 310 217 310), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 103; + $fi->{103} = $i; + $w->create('text', qw(259 287), -text => '103', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(396 188 377 188 377 169 316 169 316 131 396 131), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 124; + $fi->{124} = $i; + $w->create('text', qw(356 150), -text => '124', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(397 226 407 226 407 189 377 189 377 246 397 246), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 125; + $fi->{125} = $i; + $w->create('text', qw(392 217.5), -text => '125', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(399 187 409 187 409 207 474 207 474 164 399 164), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 126; + $fi->{126} = $i; + $w->create('text', qw(436.5 185.5), -text => '126', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 127; + $fi->{127} = $i; + $w->create('text', qw(436.5 231), -text => '127', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'MShower'; + $fi->{MShower} = $i; + $w->create('text', qw(488.5 184), -text => 'MShower', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(497 176 513 176 513 204 492 204 492 190 497 190), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'Closet'; + $fi->{Closet} = $i; + $w->create('text', qw(502.5 190), -text => 'Closet', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(476 237 476 206 513 206 513 254 488 254 488 237), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'WShower'; + $fi->{WShower} = $i; + $w->create('text', qw(494.5 230), -text => 'WShower', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 130; + $fi->{130} = $i; + $w->create('text', qw(638.5 205), -text => '130', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 102; + $fi->{102} = $i; + $w->create('text', qw(367.5 278.5), -text => '102', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(397 255 486 255 486 276 397 276), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 128; + $fi->{128} = $i; + $w->create('text', qw(441.5 265.5), -text => '128', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 129; + $fi->{129} = $i; + $w->create('text', qw(535.5 293), -text => '129', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 133; + $fi->{133} = $i; + $w->create('text', qw(628.5 335), -text => '133', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(742 387 742 281 800 281 800 387), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 132; + $fi->{132} = $i; + $w->create('text', qw(771 334), -text => '132', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(800 168 800 280 699 280 699 168), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 134; + $fi->{134} = $i; + $w->create('text', qw(749.5 224), -text => '134', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(726 131 726 166 800 166 800 131), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 135; + $fi->{135} = $i; + $w->create('text', qw(763 148.5), -text => '135', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'Ramona Stair'; + $fi->{'Ramona Stair'} = $i; + $w->create('text', qw(368 323), -text => 'Ramona Stair', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'University Stair'; + $fi->{'University Stair'} = $i; + $w->create('text', qw(155 77.5), -text => 'University Stair', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'Plaza Stair'; + $fi->{'Plaza Stair'} = $i; + $w->create('text', qw(317.5 28.5), -text => 'Plaza Stair', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 'Plaza Deck'; + $fi->{'Plaza Deck'} = $i; + $w->create('text', qw(303 81), -text => 'Plaza Deck', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(257 336 77 336 6 336 6 301 77 301 77 310 257 310), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 106; + $fi->{106} = $i; + $w->create('text', qw(131.5 318.5), -text => '106', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $i = $w->create('polygon', qw(146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131), -fill => undef, -tags => ['floor1', 'room']); + $fl->{$i} = 119; + $fi->{119} = $i; + $w->create('text', qw(143.5 133), -text => '119', -fill => $color, -anchor => 'c', -tags => ['floor1', 'label']); + $w->create('line', qw(155 191 155 189), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(155 177 155 169), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(96 129 96 169), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(78 169 176 169), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(176 247 176 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(340 206 307 206), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(340 187 340 170), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(340 210 340 201), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(340 247 340 224), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(340 241 307 241), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(376 246 376 170), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(307 247 307 170), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(376 170 307 170), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(315 129 315 170), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(147 129 176 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(202 133 176 133), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(398 129 315 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(258 352 258 387), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(60 387 60 391), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(0 337 0 391), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(60 391 0 391), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(3 114 3 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(258 387 60 387), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(52 237 52 273), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(52 189 52 225), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(52 140 52 177), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(395 306 395 311), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(531 254 398 254), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(475 178 475 238), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(502 162 398 162), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(398 129 398 188), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(383 188 376 188), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(408 188 408 194), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(398 227 398 254), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(408 227 398 227), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(408 222 408 227), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(408 206 408 210), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(408 208 475 208), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(484 278 484 311), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(484 311 508 311), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(508 327 508 311), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(559 327 508 327), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(644 391 559 391), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(644 389 644 391), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(514 205 475 205), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(496 189 496 187), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(559 129 484 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(484 162 484 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(725 133 559 133), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(559 129 559 133), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(725 149 725 167), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(725 129 802 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(802 389 802 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(739 167 802 167), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(396 188 408 188), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(0 337 9 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(58 337 21 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(43 391 43 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(105 337 75 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(91 387 91 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(154 337 117 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(139 387 139 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(227 337 166 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(258 337 251 337), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(258 328 302 328), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(302 355 302 311), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(395 311 302 311), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(484 278 395 278), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(395 294 395 278), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(473 278 473 275), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(473 256 473 254), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(533 257 531 254), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(553 276 551 274), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(698 276 553 276), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(559 391 559 327), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(802 389 644 389), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(741 314 741 389), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(698 280 698 167), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(707 280 698 280), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(802 280 731 280), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(741 280 741 302), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(698 167 727 167), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(725 137 725 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(514 254 514 175), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(496 175 514 175), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(502 175 502 162), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(475 166 475 162), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(496 176 496 175), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(491 189 496 189), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(491 205 491 189), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(487 238 475 238), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(487 240 487 238), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(487 252 487 254), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(315 133 304 133), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(256 133 280 133), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(78 247 270 247), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(307 247 294 247), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(214 133 232 133), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(217 247 217 266), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(217 309 217 291), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(217 309 172 309), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(154 309 148 309), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(175 300 175 309), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(151 300 175 300), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(151 247 151 309), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(78 237 78 265), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(78 286 78 309), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(106 309 78 309), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(130 309 125 309), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(99 309 99 247), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(127 299 99 299), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(127 309 127 299), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(155 191 137 191), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(137 169 137 191), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(78 171 78 169), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(78 190 78 218), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(86 192 86 169), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(86 192 78 192), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(52 301 3 301), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(52 286 52 301), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(52 252 3 252), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(52 203 3 203), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(3 156 52 156), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(8 25 8 114), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(63 114 3 114), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(75 114 97 114), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(108 114 129 114), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(129 114 129 89), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(52 114 52 128), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(132 89 88 89), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(88 25 88 89), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(88 114 88 89), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(218 89 144 89), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(147 111 147 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(162 111 147 111), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(162 109 162 111), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(162 96 162 89), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(218 89 218 94), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(218 89 218 119), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(8 25 88 25), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(258 337 258 328), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(113 129 96 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(302 355 258 355), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(386 104 386 129), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(377 100 386 104), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(365 94 377 100), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(350 83 365 94), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(337 70 350 83), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(337 70 323 56), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(312 49 323 56), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(295 40 312 49), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(282 37 295 40), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(260 34 282 37), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(253 34 260 34), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(386 128 386 104), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(113 152 156 152), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(113 152 156 152), -fill => $color, -tags => ['floor1', 'wall']); + $w->create('line', qw(113 152 113 129), -fill => $color, -tags => ['floor1', 'wall']); + +} # end floor_fg1; + +sub floor_fg2 {; + + my($w, $color, $fl, $fi) = @_; + + my($i); + $i = $w->create('polygon', qw(748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 238; + $fi->{238} = $i; + $w->create('text', qw(774 195), -text => '238', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(726 188 746 188 746 166 800 166 800 131 726 131), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 237; + $fi->{237} = $i; + $w->create('text', qw(763 148.5), -text => '237', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 246; + $fi->{246} = $i; + $w->create('text', qw(600 264), -text => '246', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(694 279 643 279 643 314 694 314), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 247; + $fi->{247} = $i; + $w->create('text', qw(668.5 296.5), -text => '247', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 202; + $fi->{202} = $i; + $w->create('text', qw(285.5 260), -text => '202', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 206; + $fi->{206} = $i; + $w->create('text', qw(143 267), -text => '206', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(51 277 6 277 6 338 51 338), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 212; + $fi->{212} = $i; + $w->create('text', qw(28.5 307.5), -text => '212', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(557 276 486 276 486 309 510 309 510 325 557 325), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 245; + $fi->{245} = $i; + $w->create('text', qw(521.5 300.5), -text => '245', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(560 389 599 389 599 326 560 326), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 244; + $fi->{244} = $i; + $w->create('text', qw(579.5 357.5), -text => '244', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(601 389 601 326 643 326 643 389), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 243; + $fi->{243} = $i; + $w->create('text', qw(622 357.5), -text => '243', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(688 316 645 316 645 365 688 365), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 242; + $fi->{242} = $i; + $w->create('text', qw(666.5 340.5), -text => '242', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(802 367 759 367 759 226 802 226), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 'Barbecue Deck'; + $fi->{'Barbecue Deck'} = $i; + $w->create('text', qw(780.5 296.5), -text => 'Barbecue Deck', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(755 262 755 314 717 314 717 262), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 240; + $fi->{240} = $i; + $w->create('text', qw(736 288), -text => '240', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(755 316 689 316 689 365 755 365), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 241; + $fi->{241} = $i; + $w->create('text', qw(722 340.5), -text => '241', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(755 206 717 206 717 261 755 261), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 239; + $fi->{239} = $i; + $w->create('text', qw(736 233.5), -text => '239', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(695 277 643 277 643 206 695 206), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 248; + $fi->{248} = $i; + $w->create('text', qw(669 241.5), -text => '248', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(676 135 676 185 724 185 724 135), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 236; + $fi->{236} = $i; + $w->create('text', qw(700 160), -text => '236', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(675 135 635 135 635 145 628 145 628 185 675 185), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 235; + $fi->{235} = $i; + $w->create('text', qw(651.5 160), -text => '235', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 234; + $fi->{234} = $i; + $w->create('text', qw(606 160), -text => '234', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 233; + $fi->{233} = $i; + $w->create('text', qw(552.5 158), -text => '233', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(476 249 557 249 557 205 476 205), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 230; + $fi->{230} = $i; + $w->create('text', qw(516.5 227), -text => '230', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(476 164 486 164 486 131 525 131 525 185 476 185), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 232; + $fi->{232} = $i; + $w->create('text', qw(500.5 158), -text => '232', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(476 186 495 186 495 204 476 204), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 229; + $fi->{229} = $i; + $w->create('text', qw(485.5 195), -text => '229', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(474 207 409 207 409 187 399 187 399 164 474 164), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 227; + $fi->{227} = $i; + $w->create('text', qw(436.5 185.5), -text => '227', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(399 228 399 253 474 253 474 209 409 209 409 228), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 228; + $fi->{228} = $i; + $w->create('text', qw(436.5 231), -text => '228', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(397 246 397 226 407 226 407 189 377 189 377 246), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 226; + $fi->{226} = $i; + $w->create('text', qw(392 217.5), -text => '226', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(377 169 316 169 316 131 397 131 397 188 377 188), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 225; + $fi->{225} = $i; + $w->create('text', qw(356.5 150), -text => '225', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(234 198 306 198 306 249 234 249), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 224; + $fi->{224} = $i; + $w->create('text', qw(270 223.5), -text => '224', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(270 179 306 179 306 170 314 170 314 135 270 135), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 223; + $fi->{223} = $i; + $w->create('text', qw(292 157), -text => '223', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(268 179 221 179 221 135 268 135), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 222; + $fi->{222} = $i; + $w->create('text', qw(244.5 157), -text => '222', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(177 179 219 179 219 135 177 135), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 221; + $fi->{221} = $i; + $w->create('text', qw(198 157), -text => '221', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(299 327 349 327 349 284 341 284 341 276 299 276), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 204; + $fi->{204} = $i; + $w->create('text', qw(324 301.5), -text => '204', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(234 276 297 276 297 327 257 327 257 338 234 338), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 205; + $fi->{205} = $i; + $w->create('text', qw(265.5 307), -text => '205', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(256 385 256 340 212 340 212 385), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 207; + $fi->{207} = $i; + $w->create('text', qw(234 362.5), -text => '207', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(210 340 164 340 164 385 210 385), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 208; + $fi->{208} = $i; + $w->create('text', qw(187 362.5), -text => '208', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(115 340 162 340 162 385 115 385), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 209; + $fi->{209} = $i; + $w->create('text', qw(138.5 362.5), -text => '209', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(89 228 89 156 53 156 53 228), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 217; + $fi->{217} = $i; + $w->create('text', qw(71 192), -text => '217', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(89 169 97 169 97 190 89 190), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = '217A'; + $fi->{'217A'} = $i; + $w->create('text', qw(93 179.5), -text => '217A', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(89 156 89 168 95 168 95 135 53 135 53 156), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 216; + $fi->{216} = $i; + $w->create('text', qw(71 145.5), -text => '216', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(51 179 51 135 6 135 6 179), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 215; + $fi->{215} = $i; + $w->create('text', qw(28.5 157), -text => '215', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(51 227 6 227 6 180 51 180), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 214; + $fi->{214} = $i; + $w->create('text', qw(28.5 203.5), -text => '214', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(51 275 6 275 6 229 51 229), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 213; + $fi->{213} = $i; + $w->create('text', qw(28.5 252), -text => '213', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(114 340 67 340 67 385 114 385), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 210; + $fi->{210} = $i; + $w->create('text', qw(90.5 362.5), -text => '210', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(59 389 59 385 65 385 65 340 1 340 1 389), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 211; + $fi->{211} = $i; + $w->create('text', qw(33 364.5), -text => '211', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(393 309 350 309 350 282 342 282 342 276 393 276), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 203; + $fi->{203} = $i; + $w->create('text', qw(367.5 292.5), -text => '203', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 220; + $fi->{220} = $i; + $w->create('text', qw(132.5 208.5), -text => '220', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(339 205 307 205 307 171 339 171), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 'Priv Lift2'; + $fi->{'Priv Lift2'} = $i; + $w->create('text', qw(323 188), -text => 'Priv Lift2', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(307 240 339 240 339 206 307 206), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 'Pub Lift2'; + $fi->{'Pub Lift2'} = $i; + $w->create('text', qw(323 223), -text => 'Pub Lift2', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(175 168 97 168 97 131 175 131), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 218; + $fi->{218} = $i; + $w->create('text', qw(136 149.5), -text => '218', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(154 191 111 191 111 169 154 169), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 219; + $fi->{219} = $i; + $w->create('text', qw(132.5 180), -text => '219', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $i = $w->create('polygon', qw(375 246 375 172 341 172 341 246), -fill => undef, -tags => ['floor2', 'room']); + $fl->{$i} = 201; + $fi->{201} = $i; + $w->create('text', qw(358 209), -text => '201', -fill => $color, -anchor => 'c', -tags => ['floor2', 'label']); + $w->create('line', qw(641 186 678 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(757 350 757 367), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(634 133 634 144), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(634 144 627 144), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(572 133 572 144), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(572 144 579 144), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(398 129 398 162), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(174 197 175 197), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(175 197 175 227), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(757 206 757 221), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(396 188 408 188), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(727 189 725 189), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(747 167 802 167), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(747 167 747 189), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(755 189 739 189), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(769 224 757 224), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(802 224 802 129), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(802 129 725 129), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(725 189 725 129), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(725 186 690 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(676 133 676 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(627 144 627 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(629 186 593 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(579 144 579 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(559 129 559 133), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(725 133 559 133), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(484 162 484 129), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(559 129 484 129), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(526 129 526 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(540 186 581 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(528 186 523 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(511 186 475 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(496 190 496 186), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(496 205 496 202), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(475 205 527 205), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(558 205 539 205), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(558 205 558 249), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(558 249 475 249), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(662 206 642 206), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(695 206 675 206), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(695 278 642 278), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(642 291 642 206), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(695 291 695 206), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(716 208 716 206), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(757 206 716 206), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(757 221 757 224), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(793 224 802 224), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(757 262 716 262), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(716 220 716 264), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(716 315 716 276), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(757 315 703 315), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(757 325 757 224), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(757 367 644 367), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(689 367 689 315), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(647 315 644 315), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(659 315 691 315), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(600 325 600 391), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(627 325 644 325), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(644 391 644 315), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(615 325 575 325), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(644 391 558 391), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(563 325 558 325), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(558 391 558 314), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(558 327 508 327), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(558 275 484 275), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(558 302 558 275), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(508 327 508 311), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(484 311 508 311), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(484 275 484 311), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(475 208 408 208), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(408 206 408 210), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(408 222 408 227), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(408 227 398 227), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(398 227 398 254), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(408 188 408 194), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(383 188 376 188), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(398 188 398 162), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(398 162 484 162), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(475 162 475 254), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(398 254 475 254), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(484 280 395 280), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(395 311 395 275), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(307 197 293 197), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(278 197 233 197), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(233 197 233 249), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(307 179 284 179), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(233 249 278 249), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(269 179 269 133), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(220 179 220 133), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(155 191 110 191), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(90 190 98 190), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(98 169 98 190), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(52 133 52 165), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(52 214 52 177), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(52 226 52 262), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(52 274 52 276), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(234 275 234 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(226 339 258 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(211 387 211 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(214 339 177 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(258 387 60 387), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(3 133 3 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(165 339 129 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(117 339 80 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(68 339 59 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(0 339 46 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(60 391 0 391), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(0 339 0 391), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(60 387 60 391), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(258 329 258 387), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(350 329 258 329), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(395 311 350 311), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(398 129 315 129), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(176 133 315 133), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(176 129 96 129), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(3 133 96 133), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(66 387 66 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(115 387 115 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(163 387 163 339), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(234 275 276 275), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(288 275 309 275), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(298 275 298 329), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(341 283 350 283), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(321 275 341 275), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(375 275 395 275), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(315 129 315 170), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(376 170 307 170), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(307 250 307 170), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(376 245 376 170), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(340 241 307 241), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(340 245 340 224), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(340 210 340 201), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(340 187 340 170), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(340 206 307 206), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(293 250 307 250), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(271 179 238 179), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(226 179 195 179), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(176 129 176 179), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(182 179 176 179), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(174 169 176 169), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(162 169 90 169), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(96 169 96 129), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(175 227 90 227), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(90 190 90 227), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(52 179 3 179), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(52 228 3 228), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(52 276 3 276), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(155 177 155 169), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(110 191 110 169), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(155 189 155 197), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(350 283 350 329), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(162 197 155 197), -fill => $color, -tags => ['floor2', 'wall']); + $w->create('line', qw(341 275 341 283), -fill => $color, -tags => ['floor2', 'wall']); + +} # end floor_fg2; + +sub floor_fg3 {; + + my($w, $color, $fl, $fi) = @_; + + my($i); + $i = $w->create('polygon', qw(89 228 89 180 70 180 70 228), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 316; + $fi->{316} = $i; + $w->create('text', qw(79.5 204), -text => '316', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(115 368 162 368 162 323 115 323), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 309; + $fi->{309} = $i; + $w->create('text', qw(138.5 345.5), -text => '309', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(164 323 164 368 211 368 211 323), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 308; + $fi->{308} = $i; + $w->create('text', qw(187.5 345.5), -text => '308', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(256 368 212 368 212 323 256 323), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 307; + $fi->{307} = $i; + $w->create('text', qw(234 345.5), -text => '307', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(244 276 297 276 297 327 260 327 260 321 244 321), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 305; + $fi->{305} = $i; + $w->create('text', qw(270.5 301.5), -text => '305', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(251 219 251 203 244 203 244 219), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = '324B'; + $fi->{'324B'} = $i; + $w->create('text', qw(247.5 211), -text => '324B', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(251 249 244 249 244 232 251 232), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = '324A'; + $fi->{'324A'} = $i; + $w->create('text', qw(247.5 240.5), -text => '324A', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(223 135 223 179 177 179 177 135), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 320; + $fi->{320} = $i; + $w->create('text', qw(200 157), -text => '320', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(114 368 114 323 67 323 67 368), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 310; + $fi->{310} = $i; + $w->create('text', qw(90.5 345.5), -text => '310', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(23 277 23 321 68 321 68 277), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 312; + $fi->{312} = $i; + $w->create('text', qw(45.5 299), -text => '312', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(23 229 68 229 68 275 23 275), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 313; + $fi->{313} = $i; + $w->create('text', qw(45.5 252), -text => '313', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(68 227 23 227 23 180 68 180), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 314; + $fi->{314} = $i; + $w->create('text', qw(45.5 203.5), -text => '314', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(95 179 95 135 23 135 23 179), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 315; + $fi->{315} = $i; + $w->create('text', qw(59 157), -text => '315', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(99 226 99 204 91 204 91 226), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = '316B'; + $fi->{'316B'} = $i; + $w->create('text', qw(95 215), -text => '316B', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(91 202 99 202 99 180 91 180), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = '316A'; + $fi->{'316A'} = $i; + $w->create('text', qw(95 191), -text => '316A', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 319; + $fi->{319} = $i; + $w->create('text', qw(141.5 209), -text => '319', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 311; + $fi->{311} = $i; + $w->create('text', qw(29.5 361), -text => '311', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(154 191 111 191 111 169 154 169), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 318; + $fi->{318} = $i; + $w->create('text', qw(132.5 180), -text => '318', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(175 168 97 168 97 131 175 131), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 317; + $fi->{317} = $i; + $w->create('text', qw(136 149.5), -text => '317', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(274 194 274 221 306 221 306 194), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 323; + $fi->{323} = $i; + $w->create('text', qw(290 207.5), -text => '323', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(306 222 274 222 274 249 306 249), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 325; + $fi->{325} = $i; + $w->create('text', qw(290 235.5), -text => '325', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(263 179 224 179 224 135 263 135), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 321; + $fi->{321} = $i; + $w->create('text', qw(243.5 157), -text => '321', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(314 169 306 169 306 192 273 192 264 181 264 135 314 135), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 322; + $fi->{322} = $i; + $w->create('text', qw(293.5 163.5), -text => '322', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(307 240 339 240 339 206 307 206), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 'Pub Lift3'; + $fi->{'Pub Lift3'} = $i; + $w->create('text', qw(323 223), -text => 'Pub Lift3', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(339 205 307 205 307 171 339 171), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 'Priv Lift3'; + $fi->{'Priv Lift3'} = $i; + $w->create('text', qw(323 188), -text => 'Priv Lift3', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(350 284 376 284 376 276 397 276 397 309 350 309), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 303; + $fi->{303} = $i; + $w->create('text', qw(373.5 292.5), -text => '303', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 324; + $fi->{324} = $i; + $w->create('text', qw(262 226), -text => '324', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(299 276 299 327 349 327 349 284 341 284 341 276), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 304; + $fi->{304} = $i; + $w->create('text', qw(324 301.5), -text => '304', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(375 246 375 172 341 172 341 246), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 301; + $fi->{301} = $i; + $w->create('text', qw(358 209), -text => '301', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(397 246 377 246 377 185 397 185), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 327; + $fi->{327} = $i; + $w->create('text', qw(387 215.5), -text => '327', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(316 131 316 169 377 169 377 185 397 185 397 131), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 326; + $fi->{326} = $i; + $w->create('text', qw(356.5 150), -text => '326', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 302; + $fi->{302} = $i; + $w->create('text', qw(319.5 261), -text => '302', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $i = $w->create('polygon', qw(70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275), -fill => undef, -tags => ['floor3', 'room']); + $fl->{$i} = 306; + $fi->{306} = $i; + $w->create('text', qw(200.5 284.5), -text => '306', -fill => $color, -anchor => 'c', -tags => ['floor3', 'label']); + $w->create('line', qw(341 275 341 283), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(162 197 155 197), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(396 247 399 247), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(399 129 399 311), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(258 202 243 202), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(350 283 350 329), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(251 231 243 231), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(243 220 251 220), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(243 250 243 202), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(155 197 155 190), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(110 192 110 169), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(155 192 110 192), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(155 177 155 169), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(176 197 176 227), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(69 280 69 274), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(21 276 69 276), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(69 262 69 226), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(21 228 69 228), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(21 179 75 179), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(69 179 69 214), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(90 220 90 227), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(90 204 90 202), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(90 203 100 203), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(90 187 90 179), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(90 227 176 227), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(100 179 100 227), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(100 179 87 179), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(96 179 96 129), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(162 169 96 169), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(173 169 176 169), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(182 179 176 179), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(176 129 176 179), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(195 179 226 179), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(224 133 224 179), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(264 179 264 133), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(238 179 264 179), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(273 207 273 193), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(273 235 273 250), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(273 224 273 219), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(273 193 307 193), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(273 222 307 222), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(273 250 307 250), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(384 247 376 247), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(340 206 307 206), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(340 187 340 170), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(340 210 340 201), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(340 247 340 224), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(340 241 307 241), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(376 247 376 170), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(307 250 307 170), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(376 170 307 170), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(315 129 315 170), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(376 283 366 283), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(376 283 376 275), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(399 275 376 275), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(341 275 320 275), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(341 283 350 283), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(298 275 298 329), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(308 275 298 275), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(243 322 243 275), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(243 275 284 275), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(258 322 226 322), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(212 370 212 322), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(214 322 177 322), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(163 370 163 322), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(165 322 129 322), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(84 322 117 322), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(71 322 64 322), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(115 322 115 370), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(66 322 66 370), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(52 322 21 322), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(21 331 0 331), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(21 331 21 133), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(96 133 21 133), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(176 129 96 129), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(315 133 176 133), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(315 129 399 129), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(399 311 350 311), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(350 329 258 329), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(258 322 258 370), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(60 370 258 370), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(60 370 60 391), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(0 391 0 331), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(60 391 0 391), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(307 250 307 242), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(273 250 307 250), -fill => $color, -tags => ['floor3', 'wall']); + $w->create('line', qw(258 250 243 250), -fill => $color, -tags => ['floor3', 'wall']); + +} # end floor_fg3; + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form.pl new file mode 100755 index 00000000000..bd60ef91475 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form.pl @@ -0,0 +1,31 @@ +# form.pl + +use vars qw/$TOP/; + +sub form { + + # Create a top-level window that displays a bunch of entries with + # tabs set up to move between them. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries.', + -title => 'Form Demonstration', + -iconname => 'form', + ); + my $f = $TOP->Frame->pack(-fill => 'both'); + my $row = 0; + foreach ('Name:', 'Address:', '', '', 'Phone:') { + my $e = $f->Entry(qw/-relief sunken -width 40/); + my $l = $f->Label(-text => $_, -anchor => 'e', -justify => 'right'); + $l->grid(-row => $row, -column => 0, -sticky => 'e'); + $e->grid(-row => $row++, -column => 1,-sticky => 'ew'); + $f->gridRowconfigure(1,-weight => 1); + $e->focus if $_ eq 'Name:'; + } + $TOP->bind('<Return>' => [$TOP => 'destroy']); + +} # end form + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form_mgr.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form_mgr.pl new file mode 100755 index 00000000000..1a328f94c53 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/form_mgr.pl @@ -0,0 +1,21 @@ +# Form, window management by Tix->form. + +use Tk; + +my $Main = MainWindow->new(); + +my $box4 = $Main->Label(-text => 'box4', -borderwidth => 1, -relief => "raised"); +my $box1 = $Main->Label(-text => 'box1',-borderwidth => 1, -relief => "raised"); +my $box2 = $Main->Label(-text => 'box2',-borderwidth => 1, -relief => "raised"); +my $box3 = $Main->Label(-text => 'box3',-borderwidth => 1, -relief => "raised"); + +$box1->form(-top => '%0', -left => '%0', -right => '%100'); +$box2->form(-top => $box1, -left => '%0', -right => '%50', -bottom => +$box4); +$box3->form(-top => $box1, -left => $box2, -right => '%100', -bottom => +$box4); +$box4->form(-left => '%0', -right => '%100', -bottom => '%100'); + +MainLoop; +__END__ + diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hello.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hello.pl new file mode 100755 index 00000000000..08b1a8b52ec --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hello.pl @@ -0,0 +1,51 @@ +# hello.pl + +use Config; +use Tk::widgets qw/ ROText /; +use vars qw/ $TOP /; +use strict; + +sub hello { + + my( $demo ) = @_; + + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => [ "This demonstration describes the basics of Perl/Tk programming. Besides this small user guide, there are various FAQs and other resources and tutorials available on the web, such as: + +http://phaseit.net/claird/comp.lang.perl.tk/ptkFAQ.html +http://www.perltk.org +http://user.cs.tu-berlin.de/~eserte +http://www.lehigh.edu/sol0/ptk +", -wraplength => '7i' ], + -title => 'Perl/Tk User Guide', + -iconname => 'hello', + ); + + # Pipe perldoc help output via fileevent() into a Scrolled ROText widget. + + my $t = $TOP->Scrolled( + qw/ ROText -width 80 -height 25 -wrap none -scrollbars osoe/, + ); + $t->focus; + my $cmd = $Config{installbin} . '/perldoc -t Tk::UserGuide'; + $t->pack( qw/ -expand 1 -fill both / ); + + open( H, "$cmd|" ) or die "Cannot get pTk user guide: $!"; + $TOP->fileevent( \*H, 'readable' => [ \&hello_fill, $t ] ); + +} # end hello + +sub hello_fill { + + my( $t ) = @_; + + my $stat = sysread H, my $data, 4096; + die "sysread error: $!" unless defined $stat; + if( $stat == 0 ) { # EOF + $TOP->fileevent( \*H, 'readable' => '' ); + return; + } + $t->insert( 'end', $data ); + +} # end hello_fill diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hscale.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hscale.pl new file mode 100755 index 00000000000..dcfd1437139 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/hscale.pl @@ -0,0 +1,48 @@ +# hscale.pl + +use subs qw /hscale_width/; +use vars qw/$TOP/; + +sub hscale { + + # Create a top-level window that displays a horizontal scale. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'An arrow and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow.', + -title => 'Horizontal Scale Demonstration', + -iconname => 'hscale', + ); + + my $frame = $TOP->Frame(-borderwidth => 10)->pack(qw/-side top -fill x/); + + my $canvas = $frame->Canvas( + qw/width 50 -height 50 -bd 0 -highlightthickness 0/); + $canvas->createPolygon(qw/0 0 1 1 2 2 -fill DeepSkyBlue3 -tags poly/); + $canvas->createLine (qw/0 0 1 1 2 2 0 0 -fill black -tags line/); + + my $scale = $frame->Scale(qw/-orient horizontal -length 284 -from 0 + -to 250 -tickinterval 50 -command/ => [\&hscale_width, $canvas]); + $scale->set(75); + + $canvas->pack(qw/-side top -expand yes -anchor w -fill x/); + $scale->pack(qw/-side bottom -expand yes -anchor w/); + +} # end hscale + +sub hscale_width { + + my($w, $width) = @_; + + $width += 21; + my $x2 = $width - 30; + $x2 = 21 if $x2 < 21; + $w->coords('poly', 20, 15, 20, 35, $x2, 35, $x2, 45, $width, 25, $x2, 5, + $x2, 15, 20, 15); + $w->coords('line', 20, 15, 20, 35, $x2, 35, $x2, 45, $width, 25, $x2, 5, + $x2, 15, 20, 15); + +} # end hscale_width + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/icon.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/icon.pl new file mode 100755 index 00000000000..876f1181baa --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/icon.pl @@ -0,0 +1,64 @@ +# icon.pl + +use vars qw/$TOP/; + +sub icon { + + # Create a top-level window that displays a bunch of iconic buttons. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected.', qw/-wraplength 5i/], + -title => 'Iconic Button Demonstration', + -iconname => 'icon', + ); + + $TOP->Bitmap('flagup', + -file => Tk->findINC('demos/images/flagup'), + -maskfile => Tk->findINC('demos/images/flagup'), + ); + $TOP->Bitmap('flagdown', + -file => Tk->findINC('demos/images/flagdown'), + -maskfile => Tk->findINC('demos/images/flagdown'), + ); + + my $frame = $TOP->Frame(qw/-borderwidth 10/); + $frame->pack(qw/-side top/); + + my(@pl) = qw/-side left -expand yes -padx 5m/; + my $frame_left = $frame->Frame; + $frame_left->pack(@pl); + + my $frame_b1 = $frame->Checkbutton( + -image => 'flagdown', + -selectimage => 'flagup', + -indicatoron => 0, + ); + $frame_b1->pack(@pl); + $frame_b1->configure(-selectcolor => $frame_b1->cget(-background)); + my $frame_b2 = $frame->Checkbutton( + -bitmap => '@' . Tk->findINC('demos/images/letters'), + -indicatoron => 0, + -selectcolor => 'SeaGreen1', + ); + $frame_b2->pack(@pl); + + my $letters = ''; + @pl = qw/-side top -expand yes/; + my $frame_left_b3 = $frame_left->Radiobutton( + -bitmap => '@' . Tk->findINC('demos/images/letters'), + -variable => \$letters, + -value => 'full', + ); + $frame_left_b3->pack(@pl); + my $frame_left_b4 = $frame_left->Radiobutton( + -bitmap => '@' . Tk->findINC('demos/images/noletters'), + -variable => \$letters, + -value => 'empty', + ); + $frame_left_b4->pack(@pl); + +} # end icon + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image1.pl new file mode 100755 index 00000000000..61e6ec61b77 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image1.pl @@ -0,0 +1,28 @@ +# image1.pl + +use vars qw/$TOP/; + +sub image1 { + + # This demonstration script displays two image widgets. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'This demonstration displays two images, each in a separate label widget.', + -title => 'Image Demonstration #1', + -iconname => 'image1', + ); + + my(@pl) = qw/-side top -padx .5m -pady .5m/; + $TOP->Photo('image1a', -file => Tk->findINC('demos/images/earth.gif')); + $TOP->Label(-image => 'image1a')->pack(@pl); + + $TOP->Photo('image1b', -file => Tk->findINC('demos/images/earthris.gif')); + $TOP->Label(-image => 'image1b')->pack(@pl); + +} # end image1 + +1; + + diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image2.pl new file mode 100755 index 00000000000..fd318895254 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/image2.pl @@ -0,0 +1,104 @@ +# image2.pl + +use File::Basename; +use subs qw/image2_load_dir image2_load_image/; +use vars qw/$TOP/; + +sub image2 { + + # This demonstration script creates a simple collection of widgets + # that allow you to select and view images in a Tk label. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'This demonstration allows you to view images using a Tk "photo" image. First type a directory name in the listbox, then type Return to load the directory into the listbox. Then double-click on a file name in the listbox to see that image.', + -title => 'Image Demonstration #2', + -iconname => 'image2', + ); + + my $dir_label = $TOP->Label(-text => 'Directory:'); + my $demo_img = Tk->findINC('demos/images'); + my $dir_name = $TOP->Entry(-width => 30, -textvariable => \$demo_img); + my $frog0 = $TOP->Frame; + my $frog = $frog0->Frame; + my $file_label = $frog->Label(-text => 'File:'); + my $f = $frog->Frame; + my(@pl) = qw/-side top -anchor w/; + $dir_label->pack(@pl); + $dir_name->pack(@pl); + + # All these "frog" and "toad" frames are just to repackage the listbox + # and image side by side so they fit within an SVGA screen. + + $frog0->pack; + $frog->pack(qw/-side left/); + my $toad = $frog0->Frame; + $toad->pack(qw/-side right/); + $file_label->pack(@pl); + $f->pack(@pl); + + my $f_list = $f->Listbox(-width => 20, -height => 10); + $dir_name->bind('<Return>' => [\&image2_load_dir, $f_list, \$demo_img]); + my $f_scroll = $f->Scrollbar(-command => [$f_list => 'yview']); + $f_list->configure(-yscrollcommand => [$f_scroll => 'set']); + @pl = qw/-side left -fill y -expand 1/; + $f_list->pack(@pl); + $f_scroll->pack(@pl); + $f_list->insert(0, qw(earth.gif earthris.gif mickey.gif teapot.ppm)); + + my $image2a = $TOP->Photo; + $f_list->bind('<Double-1>' => [\&image2_load_image, $image2a, \$demo_img]); + my $image_label = $toad->Label(-text => 'Image:'); + my $image = $toad->Label(-image => $image2a); + @pl = qw/-side top -anchor w/; + $image_label->pack(@pl); + $image->pack(@pl); + +} # end image2 + +sub image2_load_dir { + + # This procedure reloads the directory listbox from the directory + # named in the demo's entry. + # + # Arguments: + # e - Reference to entry widget. + # l - Reference to listbox widget. + # dir_name - Directory name reference. + + my($e, $l, $dir_name) = @_; + + $l->delete(0, 'end'); + my $i; + local *DIR; + opendir DIR, $$dir_name; + foreach $i (sort readdir DIR) { + $l->insert('end', $i); + } + closedir DIR; + +} # end image2_load_dir + +sub image2_load_image { + + # Given the name of the toplevel window of the demo and the mouse + # position, extracts the directory entry under the mouse and loads + # that file into a photo image for display. + # + # Arguments: + # l - Reference to listbox widget. + # i - Reference to image object. + # dir_name - Directory name reference. + + my($l, $i, $dir_name) = @_; + + my $e = $l->XEvent; + my($x, $y) = ($e->x, $e->y); + $i->configure(-file => "$$dir_name/" . $l->get("\@$x,$y")); + + # NOTE: $l->get('active') works just as well. + +} # end image2_load_image + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/items.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/items.pl new file mode 100755 index 00000000000..c720821babb --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/items.pl @@ -0,0 +1,358 @@ +# items.pl + +use subs qw/items_button_press items_drag items_enter items_leave items_mark + items_start_drag items_stroke items_under_area/; +use vars qw/$TOP/; + +sub items { + + # Create a top-level window containing a canvas that displays the various + # item types and allows them to be selected and moved. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ["This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tdisplays items under area.", qw/-wraplength 5i/], + -title => 'Canvas Item Demonstration', + -iconname => 'items', + ); + + my $c = $TOP->Scrolled(qw/Canvas -width 15c -height 10c -relief sunken + -borderwidth 2 -scrollbars se -scrollregion/ => + [qw/0c 0c 30c 24c/]); + $c->pack(qw/-expand yes -fill both/); + + my %iinfo = (); # item information hash + $iinfo{areaX1} = 0; + $iinfo{areaY1} = 0; + $iinfo{areaX2} = 0; + $iinfo{areaY2} = 0; + $iinfo{restore_cmd} = ''; + + + if ($Tk::VERSION cmp '800.015') { + # Display a 3x3 rectangular grid (800.016 or greater). + $c->createGrid(qw/0c 0c 10c 8c -width 2 -lines 1/); + $c->createGrid(qw/0c 0c 5c 4c -lines 1 -dash ./); + $c->createGrid(qw/0c 0c 10m 8m -width 1/); + } else { + # Display a 3x3 rectangular grid. + $c->createRectangle(qw/ 0c 0c 30c 24c -width 2/); + $c->createLine (qw/ 0c 8c 30c 8c -width 2/); + $c->createLine (qw/ 0c 16c 30c 16c -width 2/); + $c->createLine (qw/10c 0c 10c 24c -width 2/); + $c->createLine (qw/20c 0c 20c 24c -width 2/); + } + + my $font1 = '-*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*'; + my $font2 = '-*-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*'; + my($blue, $red, $bisque, $green); + if ($TOP->depth > 1) { + $blue = 'DeepSkyBlue3'; + $red = 'red'; + $bisque = 'bisque3'; + $green = 'SeaGreen3'; + } else { + $blue = 'black'; + $red = 'black'; + $bisque = 'black'; + $green = 'black'; + } + + # Set up demos within each of the areas of the grid. + + $c->createText(qw/5c .2c -text Lines -anchor n/); + $c->createLine(qw/1c 1c 3c 1c 1c 4c 3c 4c -width 2m/, -fill => $blue, + qw/-cap butt -join miter -tags item/); + $c->createLine(qw/4.67c 1c 4.67c 4c -arrow last -activedash - -tags item/); + $c->createLine(qw/6.33c 1c 6.33c 4c -arrow both -activedash . -tags item/); + $c->createLine(qw/5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c + 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c + 8.4c 4.4c -width 3 -tags item -fill/ => $red); + $c->createLine(qw/1c 5c 7c 5c 7c 7c 9c 7c -width .5c/, + -stipple => '@'.Tk->findINC('demos/images/grey.25'), + qw/-arrow both -tags item -arrowshape/ => [15, 15, 7]); + $c->createLine(qw/1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c + -cap round -join round -tags item/); + + $c->createText(qw/15c .2c -anchor n -text/ => 'Curves (smoothed lines)'); + $c->createLine(qw/11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on/, + -fill =>$blue, qw/-tags item/); + $c->createLine(qw/15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on + -arrow both -width 3 -tags item/); + $c->createLine(qw/12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c + 7.5c 12c 6c -smooth on -width 3m -cap round -tags item/, + -stipple => '@'.Tk->findINC('demos/images/grey.25'), + -fill => $red); + + $c->createText(qw/25c .2c -text Polygons -anchor n/); + $c->createPolygon(qw/21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c 4.0c + 22.5c 3.25c 21c 4.0c 21.75c 2.5c -tags item/, + -fill => $green); + $c->createPolygon(qw/25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c + 29c 4c 29c 4c -smooth on -tags item/, -fill => $red); + $c->createPolygon(qw/22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c + 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c -tags item/, + -stipple => '@'.Tk->findINC('demos/images/grey.25')); + + $c->createText(qw/5c 8.2c -text Rectangles -anchor n/); + $c->createRectangle(qw/1c 9.5c 4c 12.5c/, -outline => $red, + qw/-width 3m -tags item/); + $c->createRectangle(qw/0.5c 13.5c 4.5c 15.5c/, -fill => $green, + qw/-tags item/); + $c->createRectangle(qw/6c 10c 9c 15c -tags item/, -outline => undef, + -stipple => '@'.Tk->findINC('demos/images/grey.25'), + -fill => $blue); + + $c->createText(qw/15c 8.2c -text Ovals -anchor n/); + $c->createOval(qw/11c 9.5c 14c 12.5c/, -outline => $red, + qw/-width 3m -tags item/); + $c->createOval(qw/10.5c 13.5c 14.5c 15.5c/, -fill => $green, + qw/-tags item/); + $c->createOval(qw/16c 10c 19c 15c -tags item/, -outline => undef, + -stipple => '@'.Tk->findINC('demos/images/grey.25'), + -fill => $blue); + + $c->createText(qw/25c 8.2c -text Text -anchor n/); + $c->createRectangle(qw/22.4c 8.9c 22.6c 9.1c/); + $c->createText(qw/22.5c 9c -anchor n -width 4c/, -font => $font1, + -text => 'A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text.', qw/-tags item/); + $c->createRectangle(qw/25.4c 10.9c 25.6c 11.1c/); + $c->createText(qw/25.5c 11c -anchor w/, -font => $font1, -fill => $blue, + -text => "Several lines,\n each centered\n" . + "individually,\nand all anchored\nat the left edge.", + qw/-justify center -tags item/); + $c->createRectangle(qw/24.9c 13.9c 25.1c 14.1c/); + $c->createText(qw/25c 14c -anchor c/, -font => $font2, -fill => $red, + -stipple => 'gray50', + -text => 'Stippled characters', qw/-tags item/); + + $c->createText(qw/5c 16.2c -text Arcs -anchor n/); + $c->createArc(qw/0.5c 17c 7c 20c/, -fill => $green, qw/-outline black/, + -stipple => '@'.Tk->findINC('demos/images/grey.25'), + qw/-start 45 -extent 270 -style pieslice -tags item/); + $c->createArc(qw/6.5c 17c 9.5c 20c -width 4m -style arc/, -fill => $blue, + qw/-start -135 -extent 270 -tags item/); + $c->createArc(qw/0.5c 20c 9.5c 24c -width 4m -style pieslice/, + -fill => undef, -outline => $red, + qw/-start 225 -extent -90 -tags item/); + $c->createArc(qw/5.5c 20.5c 9.5c 23.5c -width 4m -style chord/, + -fill => $blue, -outline => undef, + qw/-start 45 -extent 270 -tags item/); + + $c->createText(qw/15c 16.2c -text Bitmaps -anchor n/); + $c->createBitmap(qw/13c 20c -bitmap/ => + '@'.Tk->findINC('demos/images/face'), qw/-tags item/); + $c->createBitmap(qw/17c 18.5c/, + -bitmap => '@'.Tk->findINC('demos/images/noletters'), + qw/-tags item/); + $c->createBitmap(qw/17c 21.5c/, + -bitmap => '@'.Tk->findINC('demos/images/letters'), + qw/-tags item/); + + $c->createText(qw/25c 16.2c -text Windows -anchor n/); + my $c_button = $c->Button(-text => 'Press Me', + -command => [\&items_button_press, $c, $red], + ); + $c->createWindow(qw/21c 18c/, -window => $c_button, + qw/-anchor nw -tags item/); + my $c_entry = $c->Entry(-width => '20', -relief => 'sunken', + -validate => 'all', + -validatecommand => sub {$n++ ? 1 : 0}, + -invalidcommand => sub {$TOP->bell}); + $c_entry->insert('end' => 'Edit this text'); + $c->createWindow(qw/21c 21c/, -window => $c_entry, + qw/-anchor nw -tags item/); + my $c_scale = $c->Scale(qw/-from 0 -to 100 -length 6c -sliderlength .4c + -width .5c -tickinterval 0/); + $c->createWindow(qw/28.5c 17.5c/, -window => $c_scale, + qw/-anchor n -tags item/); + $c->createText(qw/21c 17.9c -text Button: -anchor sw/); + $c->createText(qw/21c 20.9c -text Entry: -anchor sw/); + $c->createText(qw/28.5c 17.4c -text Scale: -anchor s/); + + # Set up event bindings for canvas. + + $c->bind('item', '<Any-Enter>' => [\&items_enter, \%iinfo]); + $c->bind('item', '<Any-Leave>' => [\&items_leave, \%iinfo]); + + # Get real canvas widget reference to apply bind() commands to: the + # Canvas widget is a subwidget of the Scrolled composite widget. To + # reference the X event structure, either use the XEvent() method or + # read the specially localized variable $Tk::event. We'll use XEvent + # first, and the variable from then on. + + $c->CanvasBind('<<Copy>>',sub { print "Do Copy\n" }); + + $c->CanvasBind('<1>' => sub { + my($c) = @_; + my $e = $c->XEvent; + items_start_drag $c, $e->x, $e->y, \%iinfo; + }); + $c->CanvasBind('<B1-Motion>' => + sub {items_drag shift, $Tk::event->x, $Tk::event->y, \%iinfo}); + $c->CanvasBind('<2>' => + sub {shift->scan('mark', $Tk::event->x, $Tk::event->y)}); + $c->CanvasBind('<B2-Motion>' => + sub {shift->scan('dragto', $Tk::event->x, $Tk::event->y)}); + $c->CanvasBind('<3>' => + sub {items_mark shift, $Tk::event->x, $Tk::event->y, \%iinfo}); + $c->CanvasBind('<B3-Motion>' => + sub {items_stroke shift, $Tk::event->x, $Tk::event->y, \%iinfo}); + $c->CanvasBind('<Control-f>' => [sub { + my($c, $iinfo) = @_; + my $e = $c->XEvent; + items_under_area $c, $iinfo; + }, \%iinfo]); + $c->CanvasBind('<Any-Enter>' => sub {$_[0]->CanvasFocus}); + +} # end items + +# Utility procedures for highlighting the item under the pointer: + +sub items_button_press { + + # Procedure that's invoked when the button embedded in the canvas + # is invoked. + + my($w, $color) = @_; + + my $i = $w->createText(qw/25c 18.1c -anchor n/, -text => 'Ouch!!', + -fill => $color); + $w->after(500, sub { $w->delete($i) }); + +} # end items_button_press + +sub items_drag { + + my($c, $x, $y, $iinfo) = @_; + + $x = $c->canvasx($x); + $y = $c->canvasy($y); + $c->move('current', $x-$iinfo->{lastX}, $y-$iinfo->{lastY}); + $iinfo->{lastX} = $x; + $iinfo->{lastY} = $y; + +} # end items_drag + +sub items_enter { + + my($c, $iinfo) = @_; + + $iinfo->{restore_cmd} = ''; + + if ($TOP->depth == 1) { + $iinfo->{restore_cmd} = ''; + return; + } + my $type = $c->type('current'); + if ($type eq 'window') { + $iinfo->{restore_cmd} = ''; + return; + } + + if ($type eq 'bitmap') { + my $bg = ($c->itemconfigure(qw/current -background/))[4]; + if (defined $bg) { + $iinfo->{restore_cmd} = "\$c->itemconfigure('current', + -background => '$bg');"; + } else { + $iinfo->{restore_cmd} = "\$c->itemconfigure('current', + -background => undef);"; + } + $c->itemconfigure(qw/current -background SteelBlue2/); + return; + } + my $fill = ($c->itemconfigure(qw/current -fill/))[4]; + my $stipple = ($c->itemconfigure(qw/current -stipple/))[4]; + if (defined $stipple) { + $iinfo->{restore_cmd} = "\$c->itemconfigure('current', + -stipple => '$stipple')"; + $c->itemconfigure(qw/current -stipple /,''); + } elsif (($type eq 'rectangle' or $type eq 'oval' or $type eq 'arc') + and not defined $fill) { + my $outline = ($c->itemconfigure(qw/current -outline/))[4]; + $iinfo->{restore_cmd} = "\$c->itemconfigure('current', + -outline => '$outline')"; + $c->itemconfigure(qw/current -outline SteelBlue2/); + } else { + $iinfo->{restore_cmd} = "\$c->itemconfigure('current', + -fill => '$fill')"; + $c->itemconfigure(qw/current -fill SteelBlue2/); + } + +} # end items_enter + +sub items_leave { + + my($c, $iinfo) = @_; + + eval $iinfo->{restore_cmd}; + +} # end items_leave + +sub items_mark { + + my($c, $x, $y, $iinfo) = @_; + + $iinfo->{areaX1} = $c->canvasx($x); + $iinfo->{areaY1} = $c->canvasy($y); + $c->delete('area'); + +} # end items_mark + +sub items_start_drag { + + my($c, $x, $y, $iinfo) = @_; + + $iinfo->{lastX} = $c->canvasx($x); + $iinfo->{lastY} = $c->canvasy($y); + +} # end items_start_drag + +sub items_stroke { + + my($c, $x, $y, $iinfo) = @_; + + $x = $c->canvasx($x); + $y = $c->canvasy($y); + if (($iinfo->{areaX1} != $x) and ($iinfo->{areaY1} != $y)) { + $c->delete('area'); + $c->addtag('area', 'withtag', $c->create('rectangle', + $iinfo->{areaX1}, $iinfo->{areaY1}, $x, $y, -outline => 'black')); + $iinfo->{areaX2} = $x; + $iinfo->{areaY2} = $y; + } + +} # end items_stroke + +sub items_under_area { + + my($c, $iinfo) = @_; + + my $area = $c->find('withtag', 'area'); + my @items = (); + my $i; + foreach $i ($c->find('enclosed', $iinfo->{areaX1}, + $iinfo->{areaY1}, $iinfo->{areaX2}, $iinfo->{areaY2})) { + my @tags = $c->gettags($i); + if (defined($tags[0]) and grep $_ eq 'item', @tags) { + push @items, $i; + } + } + @items = 'None' unless @items; + print STDOUT 'Items enclosed by area: ', join(' ', @items), ".\n"; + @items = (); + foreach $i ($c->find('overlapping', $iinfo->{areaX1}, $iinfo->{areaY1}, + $iinfo->{areaX2}, $iinfo->{areaY2})) { + my @tags = $c->gettags($i); + if (defined($tags[0]) and grep $_ eq 'item', @tags) { + push @items, $i; + } + } + @items = 'None' unless @items; + print STDOUT 'Items overlapping area: ', join(' ', @items), ".\n"; + +} # end items_under_area + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/keysyms.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/keysyms.pl new file mode 100755 index 00000000000..17f594d7061 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/keysyms.pl @@ -0,0 +1,20 @@ +use strict; + +sub keysyms { + + my( $demo ) = @_; + + my $mw = $MW->WidgetDemo( + -name => $demo, + -text => 'This demonstration displays the keysym for any keyboard character.', + -title => 'Display Keysyms', + -iconname => 'keysyms', + ); + + $mw->Label( qw/ -relief solid -width 20 /, -textvariable => \my $k )->pack; + + $mw->bind( '<KeyPress>' => sub { + $k = sprintf( "%s", $Tk::event->K ); + }); + +} # end keysyms diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labelframe.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labelframe.pl new file mode 100755 index 00000000000..17d191a7c9b --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labelframe.pl @@ -0,0 +1,74 @@ +# labelframe.pl + +use vars qw/$TOP/; + +sub labelframe { + + # Create a top-level window that displays several Labelframe widgets. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -geometry_manager => 'grid', + -name => $demo, + -text => 'Labelframes are used to group related widgets together. The label maybe either plain text or another widget.', + -title => 'Labelframe Demonstration', + -iconname => 'labelframe', + ); + + # A group of radiobuttons in a labelframe + + my $lf1 = $TOP->Labelframe(qw/-text Value -padx 2 -pady 2/); + $lf1->grid(qw/-row 0 -column 0 -pady 2m -padx 2m/); + + my $lfdummy; + foreach my $value (1 .. 4) { + $lf1->Radiobutton( + -text => "This is value $value" , + -variable => \$lfdummy, + -value => $value, + )->pack(qw/-side top -fill x -pady 2/); + } + + # A label window controlling a group of options. + + my $lf2 = $TOP->Labelframe(qw/-pady 2 -padx 2/); + $lf2->grid(qw/-row 0 -column 1 -pady 2m -padx 2m/); + my $lfdummy2; + my $cb; + $cb = $lf2->Checkbutton( + -text => 'Use this option', + -variable => \$lfdummy2, + -command => sub {&labelframe_buttons($lf2, $cb, \$lfdummy2)}, + -padx => 0, + ); + $lf2->configure(-labelwidget => $cb); + + foreach my $str (qw/Option1 Option2 Option3/) { + $lf2->Checkbutton(-text => $str)->pack(qw/-side top -fill x -pady 2/); + } + + &labelframe_buttons($lf2, $cb, \$lfdummy2); + + $TOP->gridColumnconfigure([0, 1], -weight => 1); + +} # end labelframe + +sub labelframe_buttons { + + # The state of the sub-Checkbuttons is dependent upon the state of + # the master -labelwidget Checkbutton. + + my ($lf, $cb, $var_ref) = @_; + + foreach my $child ($lf->children) { + next if $child == $cb; + if ($$var_ref) { + $child->configure(qw/-state normal/); + } else { + $child->configure(qw/-state disabled/); + } + } + +} # end labelframe_buttons + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labels.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labels.pl new file mode 100755 index 00000000000..4650ffdfd50 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labels.pl @@ -0,0 +1,43 @@ +# labels.pl + +use vars qw/$TOP/; + +sub labels { + + # Create a top-level window that displays a bunch of labels. @pl is the + # "packing list" variable which specifies the list of packer attributes. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'Five labels are displayed below: three textual ones on the left, and an image label and a text label on the right. Labels are pretty boring because you can\'t do anything with them.', + -title => 'Label Demonstration', + -iconname => 'label', + ); + + my(@pl) = qw/-side left -expand yes -padx 10 -pady 10 -fill both/; + my $left = $TOP->Frame->pack(@pl); + my $right = $TOP->Frame->pack(@pl); + + @pl = qw/-side top -expand yes -pady 2 -anchor w/; + my $left_l1 = $left->Label(-text => 'First label')->pack(@pl); + my $left_l2 = $left->Label( + -text => 'Second label, raised just for fun', + -relief => 'raised', + )->pack(@pl); + my $left_l3 = $left->Label( + -text => 'Third label, sunken', + -relief => 'sunken', + )->pack(@pl); + + @pl = qw/-side top/; + my $right_bitmap = $right->Label( + -image => $TOP->Photo(-file => Tk->findINC('Xcamel.gif')), + -borderwidth => 2, + -relief => 'sunken', + )->pack(@pl); + my $right_caption = $right->Label(-text => 'Perl/Tk')->pack(@pl); + +} # end labels + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labframe.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labframe.pl new file mode 100755 index 00000000000..c5f09f88bca --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/labframe.pl @@ -0,0 +1,13 @@ +# LabFrame, frame with embedded label. + +use Tk; +use Tk::LabFrame; +use Tk::LabEntry; + +my $test = 'Test this'; + +my $top = MainWindow->new; +my $f = $top->LabFrame(-label => "This is a label", -labelside => "acrosstop"); +$f->LabEntry(-label => "Testing", -textvariable => \$test)->pack; +$f->pack; +MainLoop; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/mega.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/mega.pl new file mode 100755 index 00000000000..cbd1b6cbd4c --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/mega.pl @@ -0,0 +1,135 @@ +# mega.pl + +use vars qw / $TOP /; +use strict; + +sub mega { + + my( $demo ) = @_; + + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => [ "Perl/Tk provides a powerful framework for creating custom widgets. There are two types of these mega-widgets: composite and derived. Subsequent demonstrations detail a complete mega-widget of each type. Regardless of the type of mega-widget, they share a common programming structure. The key that differentiates the various types of mega-widget is the definition of the new widget's base class(es).", -wraplength => '7i' ], + -title => 'Introduction to writing pure Perl mega-widgets ', + -iconname => 'mega', + ); + + my $t = $TOP->Scrolled( qw/ ROText -wrap word -scrollbars oe/ ); + $t->focus; + $t->pack( qw/ -fill both -expand 1 / ); + $t->insert( 'end', <<'end-of-instructions' ); + +Here, briefly, is the Perl/Tk mega-widget implementation for pure Perl mega-widgets. As much of the work as possible has been abstracted and incorporated into the pTk core. This mimimizes the code the mega-widget author has to write, increasing consistency. + +There are two varieties of mega-widgets in Perl/Tk: composite and derived. A composite is Toplevel or Frame-based, having other, more elemental, widgets packed (or gridded) inside. A derived widget has a ISA-like relationship, generally adding (but sometimes subtracting) options/methods to/from a single, existing, widget. Of course, that single widget may itself be a composite widget. + +To create a Perl/Tk mega-widget one: + +. chooses a namespace (class name) +. defines a subroutine to initialize the class (optional) +. defines an instance constructor (subroutine) that (optional): + . builds the new widget + . defines options (configuration specifications, analagous to C widgets) + . defines delegates for widget methods +. defines private and instance methods (optional) + +As with core widgets, methods like configure() and cget() are automatically provided by the mega-widget framework and are "just there", and option database operations "just work". + +Here is a minimal Perl/Tk Toplevel-based composite mega-widget: + + package Tk::Nil; + use base qw/Tk::Toplevel/; + Construct Tk::Widget 'Nil'; + +Unless overridden, options and methods are inherited from the mega-widget's base class(es). + +You create a Nil just like any other Perl/Tk widget: + + my $nil = $mw->Nil; + +And an empty Nil window appears that functions just like a Toplevel! But other than that, the Nil widget doesn't do anything more since no additonal subwidgets or behavior have been defined. The purpose of that example was to demonstrate how much the Perl/Tk mega-widget mechanism did for the mega-widget author - a fully functional composite mega-widget in three lines of code. + +There's a second container-like mega-widget in Perl/Tk, based on a Frame. But other than the logical container, the two mega-widget types are more-or-less equivalent. The third and final mega-widget type we call a derived mega-widget, because it adds or subtracts behavior to/from an existing widget. + +Functional mega-widgets look more like this: + + package Tk::MyNewWidget; + + # Declare base class. + use base qw/ Tk::Frame /; # Frame-based composite +or + use base qw/ Tk::Toplevel /; # Toplevel-based composite +or + use Tk:SomeWidget; + use base qw/ Tk::Derived Tk::SomeWidget /; # derived from SomeWidget + + Construct Tk::Widget 'MyNewWidget'; # install MyNewWidget in pTk namespace + + sub ClassInit{ # called once to initialize new class + my($class, $mw) = @_; + $class->SUPER::ClassInit($mw); + } + + sub Populate { # called to build each widget instance + my($self, $args) = @_; + $self->SUPER::Populate($args); + $self->Advertise(); # advertise subwidgets + $self->Callback(); # invoke -command callbacks + $self->Component(); # define a subwidget component + $self->ConfigSpecs(); # define cget() / configure() options + $self->Delegates(); # how methods are delegated to subwidgets + $self->Subwidget(); # map a subwidget name to subwidget reference + } + + # Private methods. + + # Public methods. + + 1; # end class MyNewWidget + + # Don't forget POD documentation here! + +Here's an excerpt from a Text dervived mega-widget called TraceText; you can examine the complete code in another demonstration. This widget defines its content using a new -textvariable option. + + package Tk::TraceText; + use base qw/Tk::Derived Tk::Text/; + Construct Tk::Widget 'TraceText'; + + sub Populate { + + my( $self, $args ) = @_; + + $self->ConfigSpecs( + -textvariable => 'METHOD', 'textVariable', 'TextVariable', undef, + ); + + } # end Populate + + # Private methods. + + sub textvariable { + + my ( $self, $vref ) = @_; + + $self->traceVariable( $vref, 'w', [ \&tracew => $self, $vref ] ); + $self->{_vref} = $vref; # store watchpoint in an instance variable + + } # end textvariable + +If you compare the preamble (the first three lines) with that of the Nil mega-widget, you'll note that they are virtually identical - the important difference is the addition of the Tk::Derived class that provides additional methods specifically for derived mega-widgets. + +At that point, with three lines of code, we have a completely functional mega-widget called TraceText that is identical to the standard Text widget in every way, and the key to all this is the Construct() call, which, among other duties, installs the new widget name in the symbol table. + +Construct() also arranges for the TraceText "instantiator" to call-out to the well-known method Populate() - this is how the mega-widget author adds behavior to the new widget. Similarly, the mega-widget author can provide a ClassInit() method that is called once per MainWindow to initialize class bindings, variables, images, etcetera. + +Tk::TraceText::Populate defines the -textvariable option and provides a private method to establish the watchpoint. In Perl/Tk, all mega-widget options are specified via a ConfigSpecs() call, named after the C structure. + +Briefly, ConfigSpecs() names options and tells Perl/Tk what to do when one is specified on a configure() or cget() call. It also specifies the option's database name, class name and default value for option DB lookups. For our -textvariable option, the Perl/Tk framework invokes a METHOD (subroutine) by the same name as the option, minus the dash, of course. Other choices include CHILDREN, DECENDENTS, a name (or list of names) of a subwidget, etcetera. + +More details on mega-widget construction can be found in these man pages: + +Tk::ConfigSpecs, Tk::Derived, Tk::composite, Tk::mega + +end-of-instructions + +} # end mega diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menbut.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menbut.pl new file mode 100755 index 00000000000..9fd624bdc22 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menbut.pl @@ -0,0 +1,122 @@ +# menbut.pl + +use vars qw/$TOP/; + +sub menbut { + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => '', + -title => 'Menubutton Demo', + -iconname => 'Menubutton', + ); + + my @menubuttons; + foreach (qw/below right left above/) { + my $pos = ucfirst; + my $menubutton = $TOP->Menubutton(qw/-underline 0 -relief raised/, + -text => $pos, -direction => $_); + push @menubuttons, $menubutton; + my $menu = $menubutton->menu(qw/-tearoff 0/); + $menubutton->configure(-menu => $menu); + $menubutton->command(-label => "$pos menu: first item", -command => + sub {print "You selected the first item from the $pos menu.\n"}); + $menubutton->command(-label => "$pos menu: second item", -command => + sub {print "You selected the second item from the $pos menu.\n"}); + } + $menubuttons[0]->grid(qw/-row 0 -column 1 -sticky n/); + $menubuttons[3]->grid(qw/-row 2 -column 1 -sticky n/); + $menubuttons[1]->grid(qw/-row 1 -column 0 -sticky w/); + $menubuttons[2]->grid(qw/-row 1 -column 2 -sticky e/); + + my $body = $TOP->Frame; + $body->grid(qw/-row 1 -column 1 -sticky news/); + $body->Label(qw/-wraplength 300 -justify left/, -font => 'Helvetica 14', + -text => 'This is a demonstration of menubuttons. The "Below" menubutton pops its menu below the button; the "Right" button pops to the right, etc. There are two option menus directly below this text; one is just a standard menu and the other is a 16-color palette.')->pack(qw/-side top -padx 25 + -pady 25/); + $bbutt = $body->Frame->pack(qw/-padx 25 -pady 25/); + $bbutt->Optionmenu(-options => [qw/one two three/])->pack(qw/-side left + -padx 25 -pady 25/); + + my $palette; + my(@colors) = qw/Black red4 DarkGreen NavyBlue gray75 Red Green Blue + gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet/; + + my $colors = native_optionmenu( + $bbutt, + \$palette, + [sub {print "args=@_.\n"}, 'First'], + @colors, + ); + $colors->pack(qw/-side left -padx 25 -pady 25/); + + my $menu = $colors->cget(-menu); + my $topborder = 'gray50'; + my $bottomborder = 'gray75'; + + foreach my $i (0 .. $#colors) { + + # Create a 16 pixel x 16 pixel solid color swatch. + # Add a black ring around the currently selected item. + + my $color = $menu->entrycget($i, -label); + my $p = $TOP->Photo(qw/-width 16 -height 16/); + $p->put($topborder, qw/-to 0 0 16 1/); + $p->put($topborder, qw/-to 0 1 1 16/); + $p->put($bottomborder, qw/-to 1 15 16 16/); + $p->put($bottomborder, qw/-to 15 1 16 15/); + $p->put($color, qw/-to 1 1 15 15/); + + my $r = $TOP->Photo(qw/-width 16 -height 16/); + $r->put(qw/black -to 0 0 16 2/); + $r->put(qw/black -to 0 2 2 16/); + $r->put(qw/black -to 2 14 16 16/); + $r->put(qw/black -to 14 2 16 14/); + $r->put($color , qw/-to 2 2 14 14/); + + $menu->entryconfigure($i, -columnbreak => 1) unless $i % 4; + $menu->entryconfigure($i, + -image => $p, + -hidemargin => 1, + -selectimage => $r, + ); + + } # forend all colors + + $menu->configure(-tearoff => 1); + +} # end menbut + +sub native_optionmenu { + + my($parent, $varref, $command, @optionvals) = @_; + + $$varref = $optionvals[0]; + + my $mb = $parent->Menubutton( + -textvariable => $varref, + -indicatoron => 1, + -relief => 'raised', + -borderwidth => 2, + -highlightthickness => 2, + -anchor => 'c', + -direction => 'flush', + ); + my $menu = $mb->Menu(-tearoff => 0); + $mb->configure(-menu => $menu); + + my $callback = ref($command) =~ /CODE/ ? [$command] : $command; + + foreach (@optionvals) { + $menu->radiobutton( + -label => $_, + -variable => $varref, + -command => [@$callback, $_], + ); + } + + $mb; + +} # end native_optionmenu + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus.pl new file mode 100755 index 00000000000..10fa7bfac89 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus.pl @@ -0,0 +1,196 @@ +# menus.pl + +use subs qw/menus_error/; +use vars qw/$TOP/; + +sub menus { + + # This demonstration script creates a window with a bunch of menus + # and cascaded menus using a menubar. A <<MenuSelect>> virtual event + # tracks the active menu item. + + my ($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['', -wraplength => '5i'], + -title => 'Menu Demonstration', + -iconname => 'menus', + ); + + my $ws = $TOP->windowingsystem; + + my $text = ($ws eq 'classic' or $ws eq 'aqua') ? + 'This window contains a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where "x" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging outside of its bounds and releasing the mouse.' : + 'This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where "x" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu.'; + + $TOP->configure(-text => $text); + + my $toplevel = $TOP->toplevel; # get $TOP's Toplevel widget reference + my $menubar = $toplevel->Menu(-type => 'menubar'); + $toplevel->configure(-menu => $menubar); + + my $modifier; + if ( $ws eq 'classic' or $ws eq 'aqua') { + $modifier = 'Command'; + } elsif ($Tk::platform eq 'windows') { + $modifier = 'Control'; + } else { + $modifier = 'Meta'; + } + + my $f = $menubar->cascade(-label => '~File', -tearoff => 0); + $f->command(-label => 'Open ...', -command => [\&menus_error, 'Open'], + -image => $toplevel->Getimage("openfile"), -compound => "left"); + $f->command(-label => 'New', -command => [\&menus_error, 'New'], + -image => $toplevel->Getimage("file"), -compound => "left"); + $f->command(-label => 'Save', -command => [\&menus_error, 'Save']); + $f->command(-label => 'Save As ...', -command => [\&menus_error, 'Save As']); + $f->separator; + $f->command(-label => 'Setup ...', -command => [\&menus_error, 'Setup']); + $f->command(-label => 'Print ...', -command => [\&menus_error, 'Print']); + $f->separator; + $f->command(-label => 'Quit', -command => [$TOP => 'bell']); + + my $b = $menubar->cascade(-label => '~Basic', -tearoff => 0); + $b->command(-label => 'Long entry that does nothing'); + my $label; + foreach $label (qw/A B C D E F/) { + $b->command( + -label => "Print letter \"$label\"", + -underline => 14, + -accelerator => "$modifier+$label", + -command => sub {print "$label\n"}, + ); + $TOP->bind("<$modifier-${label}>" => sub {print "$label\n"}); + } + my $c = $menubar->cascade(-label => '~Cascades', -tearoff => 0); + $c->command( + -label => 'Print hello', + -command => sub {print "Hello\n"}, + -accelerator => "$modifier+H", + -underline => 6, + ); + $TOP->bind("<$modifier-h>" => sub {print "Hello\n"}); + $c->command( + -label => 'Print goodbye', + -command => sub {print "Goodbye\n"}, + -accelerator => "$modifier+G", + -underline => 6, + ); + $TOP->bind("<$modifier-g>" => sub {print "Goodbye\n"}); + my $cc = $c->cascade(-label => '~Check buttons', -tearoff => 0); + + $cc->checkbutton(-label => 'Oil checked', -variable => \$OIL); + $cc->checkbutton(-label => 'Transmission checked', -variable => \$TRANS); + $cc->checkbutton(-label => 'Brakes checked', -variable => \$BRAKES); + $cc->checkbutton(-label => 'Lights checked', -variable => \$LIGHTS); + $cc->separator; + $cc->command( + -label => 'See current values', + -command => [\&see_vars, $MW, [ + ['oil', \$OIL], + ['trans', \$TRANS], + ['brakes', \$BRAKES], + ['lights', \$LIGHTS], + ], + ], + ); + my $cc_menu = $cc->cget(-menu); + $cc_menu->invoke(1); + $cc_menu->invoke(3); + + my $rc = $c->cascade(-label => '~Radio buttons', -tearoff => 0); + + foreach $label (qw/10 14 18 24 32/) { + $rc->radiobutton( + -label => "$label point", + -variable => \$POINT_SIZE, + -value => $label, + ); + } + $rc->separator; + foreach $label (qw/Roman Bold Italic/) { + $rc->radiobutton( + -label => $label, + -variable => \$FONT_STYLE, + -value => $label, + ); + } + $rc->separator; + $rc->command( + -label => 'See current values', + -command => [\&see_vars, $MW, [ + ['point size', \$POINT_SIZE], + ['font style', \$FONT_STYLE], + ], + ], + ); + my $rc_menu = $rc->cget(-menu); + $rc_menu->invoke(1); + $rc_menu->invoke(7); + + my $i = $menubar->cascade(-label => '~Icons', -tearoff => 0); + $i->command( + -bitmap => '@'.Tk->findINC('demos/images/pattern'), + -command => sub { + $TOP->messageBox( + -title => 'Bitmap Menu Entry', + -message => 'The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.', + -type => 'ok'), + }, + -hidemargin => 1, + ); + foreach $label (qw/info questhead error/) { + $i->command( + -bitmap => $label, + -command => sub {print "You invoked the \"$label\" bitmap\n"}, + -hidemargin => 1, + ); + } + $i->cget(-menu)->entryconfigure(2, -columnbreak => 1); + + my $m = $menubar->cascade(-label => '~More', -tearoff => 0); + foreach $label ('An entry', 'Another entry', 'Does nothing', + 'Does almost nothing', 'Make life meaningful') { + $m->command( + -label => $label, + -command => sub {print "You invoked \"$label\"\n"}, + ); + } + + my $k = $menubar->cascade(-label => 'C~olors'); + foreach $label (qw/red orange yellow green blue/) { + $k->command( + -label => $label, + -background => $label, + -command => sub {print "You invoked \"$label\"\n"}, + ); + } + + my $status_bar; + $TOP->Label( + qw/-relief sunken -borderwidth 1 -anchor w/, + -font => 'Helvetica 10', -textvariable => \$status_bar)-> + pack(qw/-padx 2 -pady 2 -expand yes -fill both/); + $menubar->bind('<<MenuSelect>>' => sub { + $status_bar = undef; + $status_bar = $_[0]->entrycget('active', -label); + $TOP->idletasks; + }); + +} # end menus + +sub menus_error { + + # Generate a background error, which may even be displayed in a window if + # using ErrorDialog. + + my($msg) = @_; + + $msg = "This is just a demo: no action has been defined for \"$msg\"."; + $TOP->BackTrace($msg); + +} # end menus_error + + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus2.pl new file mode 100755 index 00000000000..632b786b524 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/menus2.pl @@ -0,0 +1,216 @@ +# menus2.pl + +use subs qw/menus_error2/; +use vars qw/$TOP/; + +sub menus2 { + + # This demonstration script creates a window with a bunch of menus + # and cascaded menus, but uses the unique Perl/Tk -menuitems way. + # A <<MenuSelect>> virtual event tracks the active menu item. + + my ($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['', -wraplength => '5i'], + -title => 'Menuitems Demonstration', + -iconname => 'menus2', + ); + + my $ws = $TOP->windowingsystem; + + my $text = ($ws eq 'classic' or $ws eq 'aqua') ? + 'This window contains a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where "x" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging outside of its bounds and releasing the mouse.' : + 'This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where "x" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu.'; + + $TOP->configure(-text => $text); + + my $toplevel = $TOP->toplevel; # get $TOP's Toplevel widget reference + my $menubar = $toplevel->Menu(-type => 'menubar'); + $toplevel->configure(-menu => $menubar); + + my $modifier; + if ( $ws eq 'classic' or $ws eq 'aqua') { + $modifier = 'Command'; + } elsif ($Tk::platform eq 'windows') { + $modifier = 'Control'; + } else { + $modifier = 'Meta'; + } + + my $f = $menubar->Cascade(qw/-label ~File -tearoff 0 -menuitems/ => + [ + [Button => 'Open ...', -command => [\&menus_error2, 'Open'], + -image => $toplevel->Getimage("openfile"), + -compound=> "left", + ], + [Button => 'New', -command => [\&menus_error2, 'New'], + -image => $toplevel->Getimage("file"), + -compound=> "left", + ], + [Button => 'Save', -command => [\&menus_error2, 'Save']], + [Button => 'Save As ...', -command => [\&menus_error2, 'Save As']], + [Separator => ''], + [Button => 'Setup ...', -command => [\&menus_error2, 'Setup']], + [Button => 'Print ...', -command => [\&menus_error2, 'Print']], + [Separator => ''], + [Button => 'Quit', -command => [$TOP => 'bell']], + ], + ); + + my $b = $menubar->Cascade(qw/-label ~Basic -tearoff 0 -menuitems/ => + [ + [Button => 'Long entry that does nothing'], + map ( + [Button => "Print letter \"~$_\"", + -command => [sub {print "$_[0]\n"}, $_], + -accelerator => "Meta+$_" ], + ('a' .. 'g') + ), + ], + ); + + my $menu_cb = '~Check buttons'; + my $menu_rb = '~Radio buttons'; + + my $c = $menubar->Cascade(qw/-label ~Cascades -tearoff 0 -menuitems/ => + [ + [Button => 'Print ~hello', -command => sub {print "Hello\n"}, + -accelerator => 'Control+a'], + [Button => 'Print ~goodbye', -command => sub {print "Goodbye\n"}, + -accelerator => 'Control+b'], + [Cascade => $menu_cb, -tearoff => 0, -menuitems => + [ + [Checkbutton => 'Oil checked', -variable => \$OIL], + [Checkbutton => 'Transmission checked', -variable => \$TRANS], + [Checkbutton => 'Brakes checked', -variable => \$BRAKES], + [Checkbutton => 'Lights checked', -variable => \$LIGHTS], + [Separator => ''], + [Button => 'See current values', -command => + [\&see_vars, $TOP, [ + ['oil', \$OIL], + ['trans', \$TRANS], + ['brakes', \$BRAKES], + ['lights', \$LIGHTS], + ], + ], # end see_vars + ], # end button + ], # end checkbutton menuitems + ], # end checkbuttons cascade + [Cascade => $menu_rb, -tearoff => 0, -menuitems => + [ + map ( + [Radiobutton => "$_ point", -variable => \$POINT_SIZE, + -value => $_, + ], + (qw/10 14 18 24 32/), + ), + [Separator => ''], + map ( + [Radiobutton => "$_", -variable => \$FONT_STYLE, + -value => $_, + ], + (qw/Roman Bold Italic/), + ), + [Separator => ''], + [Button => 'See current values', -command => + [\&see_vars, $TOP, [ + ['point size', \$POINT_SIZE], + ['font style', \$FONT_STYLE], + ], + ], # end see_vars + ], # end button + ], # end radiobutton menuitems + ], # end radiobuttons cascade + ], + ); + + $TOP->bind('<Control-a>' => sub {print "Hello\n"}); + $TOP->bind('<Control-b>' => sub {print "Goodbye\n"}); + + # Fetch the Cascades menu, and from that get the checkbutton and + # radiobutton cascade menus and invoke a few menu items. + + my $cm = $c->cget(-menu); + $menu_cb = substr $menu_cb, 1; + my $cc = $cm->entrycget($menu_cb, -menu); + $cc->invoke(1); + $cc->invoke(3); + $menu_rb = substr $menu_rb, 1; + my $cr = $cm->entrycget($menu_rb, -menu); + $cr->invoke(1); + $cr->invoke(7); + + my $i = $menubar->Cascade(qw/-label ~Icons -tearoff 0 -menuitems/ => + [ + [Button => '', -bitmap => '@'.Tk->findINC('demos/images/pattern'), + -command => sub { + $TOP->messageBox( + -title => 'Bitmap Menu Entry', + -message => 'The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.', + -type => 'ok'), + }, + ], + map ( + [Button => '', -bitmap => $_, + -command => + [sub {print "You invoked the \"$_[0]\" bitmap\n"}, $_]], + (qw/info questhead error/), + ), + ], + ); + my $im = $i->cget(-menu); + $im->entryconfigure(2, -columnbreak => 1); + + my $m = $menubar->Cascade(qw/-label ~More -tearoff 0 -menuitems/ => + [ + map ( + [Button => $_, + -command => + [sub {print "You invoked \"$_[0]\"\n"}, $_]], + ('An entry', 'Another entry', 'Does nothing', + 'Does almost nothing', 'Make life meaningful'), + ), + ], + ); + + my $k = $menubar->cascade(qw/-label C~olors -tearoff 1 -menuitems/ => + [ + map ( + [Button => $_, + -background => $_, + -command => + [sub {print "You invoked \"$_[0]\"\n"}, $_]], + (qw/red orange yellow green blue/), + ), + ], + ); + + my $status_bar; + $TOP->Label( + qw/-relief sunken -borderwidth 1 -anchor w/, + -font => 'Helvetica 10', -textvariable => \$status_bar)-> + pack(qw/-padx 2 -pady 2 -expand yes -fill both/); + $menubar->bind('<<MenuSelect>>' => sub { + $status_bar = undef; + $status_bar = $_[0]->entrycget('active', -label); + $TOP->idletasks; + }); + +} # end menus2 + +sub menus_error2 { + + + # Generate a background error, which may even be displayed in a window if + # using ErrorDialog. + + my($msg) = @_; + + $msg = "This is just a demo: no action has been defined for \"$msg\"."; + $TOP->BackTrace($msg); + +} # end menus_error + + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/msgBox.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/msgBox.pl new file mode 100755 index 00000000000..4ac739519e8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/msgBox.pl @@ -0,0 +1,82 @@ +# msgBox.pl + +use vars qw/$TOP/; + +sub msgBox { + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'Choose the icon and type option of the message box. Then press the "Message Box" button to see the message box.', + -title => 'messageBox Demo', + -iconname => 'messageBox', + ); + + my $upper = $TOP->Frame->pack; + my $left = $upper->Frame; + my $right = $upper->Frame; + $left->pack(qw/-side left -expand yes -fill y -pady .5c -padx .5c/); + $right->pack(qw/-side left -expand yes -fill y -pady .5c -padx .5c/); + + my $icon = $left->Label(qw/-text Icon/); + my $lsep = $left->Frame(qw/-relief ridge -bd 1 -height 2/); + $icon->pack(qw/-side top/); + $lsep->pack(qw/-side top -fill x -expand no/); + + my $iconvar = 'info'; + foreach my $i (qw/error info question warning/) { + $left->Radiobutton(-text => $i, -variable => \$iconvar, -value => $i, + qw/-width 16 -anchor w -relief flat/)->pack( + qw/-side top -pady 2 -anchor w -fill x/); + } + + + my $rl = $right->Label(qw/-text Type/); + my $rsep = $right->Frame(qw/-relief ridge -bd 1 -height 2/); + $rl->pack(qw/-side top/); + $rsep->pack(qw/-side top -fill x -expand no/); + + my $typevar = 'OK'; + foreach my $t (qw/AbortRetryIgnore OK OKCancel RetryCancel YesNo YesNoCancel/) { + $right->Radiobutton(-text => $t, -variable => \$typevar, -value => $t, + qw/-relief flat -width 16 -anchor w/)->pack( + qw/-side top -pady 2 -anchor w -fill x/); + } + + { + my $cbf = $TOP->Frame->pack(-fill => 'x', -padx => '.5c', -pady => 3); + my $fd; + my $fdb = $cbf->Radiobutton + (-text => 'Tk::DialogBox', + -variable => \$fd, + -value => 'DialogBox', + -command => sub { local($^W) = 0; + *Tk::tk_messageBox = sub{ Tk::MessageBox('tk_messageBox', @_) }; + })->pack(-side => 'left'); + $cbf->Radiobutton + (-text => 'Tk::MsgBox', + -variable => \$fd, + -value => 'MsgBox', + -command => sub { local($^W) = 0; + require Tk::MsgBox; + Tk::MsgBox->import('as_default'); + })->pack(-side => 'left'); + $fdb->invoke; + } + + my $show = $TOP->Button(-text => "Message Box", + -command => [\&show_messageBox, \$iconvar, \$typevar]); + $show->pack; + +} # end msgBox + +sub show_messageBox { + my($iconvar, $typevar) = @_; + + my $button = $TOP->messageBox('-icon' => $$iconvar, -type => $$typevar, + -title => 'Message', + -message => "This is a \"$$typevar\" type messagebox with the \"$$iconvar\" icon"); + + $TOP->messageBox(qw/-icon info -type OK -message/ => "You have selected \"$button\""); + +} # end show_messageBox + diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/notebook.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/notebook.pl new file mode 100755 index 00000000000..ed45ef83190 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/notebook.pl @@ -0,0 +1,59 @@ +# Notebook, selectable pages. + +use Tk; +use Tk::DialogBox; +use Tk::NoteBook; +use Tk::LabEntry; + +my $name = "Rajappa Iyer"; +my $email = "rsi\@netcom.com"; +my $os = "Linux"; + +use vars qw($top); + +$top = MainWindow->new; +my $pb = $top->Button(-text => "Notebook", -command => \&donotebook); +$pb->pack; +MainLoop; + + +my $f; + +sub donotebook { + if (not defined $f) { + # The current example uses a DialogBox, but you could just + # as easily not use one... replace the following by + # $n = $top->NoteBook(-ipadx => 6, -ipady => 6); + # Of course, then you'd have to take care of the OK and Cancel + # buttons yourself. :-) + $f = $top->DialogBox(-title => "Personal Profile", + -buttons => ["OK", "Cancel"]); + my $n = $f->add('NoteBook', -ipadx => 6, -ipady => 6); + + my $address_p = $n->add("address", -label => "Address", -underline => 0); + my $pref_p = $n->add("pref", -label => "Preferences", -underline => 0); + + $address_p->LabEntry(-label => "Name: ", + -labelPack => [-side => "left", -anchor => "w"], + -width => 20, + -textvariable => \$name)->pack(-side => "top", -anchor => "nw"); + $address_p->LabEntry(-label => "Email Address:", + -labelPack => [-side => "left", -anchor => "w"], + -width => 50, + -textvariable => \$email)->pack(-side => "top", -anchor => "nw"); + $pref_p->LabEntry(-label => "Operating System:", + -labelPack => [-side => "left"], + -width => 15, + -textvariable => \$os)->pack(-side => "top", -anchor => "nw"); + $n->pack(-expand => "yes", + -fill => "both", + -padx => 5, -pady => 5, + -side => "top"); + + } + my $result = $f->Show; + if ($result =~ /OK/) { + print "name = $name, email = $email, os = $os\n"; + } +} + diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned1.pl new file mode 100755 index 00000000000..4a988ddd6da --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned1.pl @@ -0,0 +1,26 @@ +# paned1.pl + +use vars qw/$TOP/; + +sub paned1 { + + # This demonstration script creates a toplevel window containing + # a paned window that separates two windows horizontally. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'The sash between the two coloured windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)', + -title => 'Horizontal Paned Window Demonstration', + -iconname => 'paned1', + ); + + my $pw = $TOP->Panedwindow; + $pw->pack(qw/-side top -expand yes -fill both -pady 2 -padx 2m/); + + my $l1 = $pw->Label(-text => "This is the\nleft side", -background => 'yellow'); + my $l2 = $pw->Label(-text => "This is the\nright side", -background =>'cyan'); + + $pw->add($l1, $l2); + +} # end paned1 diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned2.pl new file mode 100755 index 00000000000..28ccf0ba4bf --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/paned2.pl @@ -0,0 +1,65 @@ +# paned2.pl + +use vars qw/$TOP/; + +sub paned2 { + + # This demonstration script creates a toplevel window containing + # a paned window that separates two windows vertically. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'The sash between the two scrolled windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)', + -title => 'Vertical Paned Window Demonstration', + -iconname => 'paned2', + ); + + my $pw = $TOP->Panedwindow(qw/-orient vertical/); + $pw->pack(qw/-side top -expand yes -fill both -pady 2 -padx 2m/); + + my $paneList = [ + 'List of Tk Widgets', qw/ + button + canvas + checkbutton + entry + frame + label + labelframe + listbox + menu + menubutton + message + panedwindow + radiobutton + scale + scrollbar + spinbox + text + toplevel + /, + ]; + + my $f1 = $pw->Frame; + my $lb = $f1->Listbox(-listvariable => $paneList); + $lb->pack(qw/-fill both -expand 1/); + my ($fg, $bg) = ($lb->cget(-foreground), $lb->cget(-background)); + $lb->itemconfigure(0, + -background => $fg, + -foreground => $bg, + ); + + my $f2 = $pw->Frame; + my $t = $f2->Text(qw/-width 30 -wrap none/); + + $t->grid(qw/-sticky nsew/); + $f2->gridColumnconfigure(qw/0 -weight 1/); + $f2->gridRowconfigure(qw/0 -weight 1/); + $t->insert('1.0', 'This is just a normal text widget'); + + $pw->add($f1, $f2); + +} # end paned2 + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo1.pl new file mode 100755 index 00000000000..aed66103bb2 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo1.pl @@ -0,0 +1,30 @@ +# photo1.pl + +use vars qw/$TOP/; + +sub photo1 { + + my($demo) = @_; + + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'This demonstration displays, for two seconds, a picture of a teapot over a green background, then proceeeds to render transparent a 50 x 50 pixel area of the teapot so that the green background shows through.', + -title => 'Transparent Pixels', + -iconname => 'photo1', + ); + + my $l = $TOP->Label( qw/ -background green -width 300 -height 300 / )->pack; + + my $f1 = $TOP->Photo( -file => Tk->findINC( 'demos/images/teapot.ppm' ) ); + $l->configure( -image => $f1 ); + $TOP->idletasks; + $TOP->after(2000); + + foreach my $x ( 50 .. 100 ) { + foreach my $y ( 50 .. 100 ) { + $f1->transparencySet( $x, $y, 1 ); + $f1->update; + } + } + +} # end photo1 diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo2.pl new file mode 100755 index 00000000000..d55d8210423 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/photo2.pl @@ -0,0 +1,156 @@ +# photo2.pl + +use vars qw/ $TOP $photo2_use_bg /; +use strict; + +sub photo2 { + + my( $demo ) = @_; + + my $alpha; # transparency + my( $dx, $dy ) = ( 0, 0 ); # delta offsets + my $svar = 100; # Scale variable + $photo2_use_bg = 0; # nz IFF a green background + + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => [ "This demonstration illustrates compositing. Commonly, each pixel of a color image is represented by three color components, red, green and blue, each specifiying a relative percentage of the color \"white\", such that, when the components are combined, they produce a visible color. Here are a few samples of 8-bit RGB triplets and the visible colors they produce:\n +(255, 255, 255) = white (000, 000, 000) = black\n(255, 000, 000) = red (000, 255, 000) = green (000, 000, 255) = blue\n\nAn additional transparency factor can be supplied that describes the importance of each pixel's RGB components when composited over another image. This transparency channel is called the Alpha channel. Although the Alpha channel is said to contain transparency information, in fact, it actually contains opacity information.\n\nIt is still possible to think in terms of transparency, although in this case the transparency is applied to the background image over which the current image is composited. The composited color is computed as:\n\n (image_RGB_component * alpha) + (background_RGB_component * (1.0 - alpha))", -wraplength => 640 ], + -title => 'Alpha Channel Compositing', + -iconname => 'photo2', + ); + + my $mw = $TOP; + my $i1 = $mw->Photo( -file => Tk->findINC( 'demos/images/earth.gif' ) ); + my $i2 = $mw->Photo( -file => Tk->findINC( 'demos/images/earthris.gif' ) ); + my $i3 = $mw->Photo( qw/ -format png -width 320 -height 200 / ); + + my $tf = $mw->Frame; + $tf->Label( -image => $i2 )->pack( qw/ -side left / ); + $tf->Label( -image => $i1 )->pack( qw/ -side left / ); + + my $bf = $mw->Frame; + my $controls = $bf->Frame; + my $results = $bf->Frame; + + $controls->pack( qw/ -side left -fill both -expand 1/ ) ; + $results->pack( qw/ -side right/ ); + + $controls->Label( + -font => '9x15', + -foreground => 'blue', + -text => 'Left Image Options', + )->pack; + my $s = $controls->Scale( + qw/ + -from 100.0 + -resolution 10.0 + -tickinterval 10.0 + -to 0.0 + /, + -label => '% Opacity', + -variable => \$svar, + ); + $svar = 80; + + my $spacer = $controls->Frame( qw/ -borderwidth 2 -relief solid -width 5/ ); + + my $rt = $controls->Label( -text => 'Background' ); + my $r = $controls->Frame; + my $r1 = $r->Radiobutton( + -anchor => 'w', + -text => 'Right Image', + -value => 0, + -variable => \$photo2_use_bg, + -width => 20, + ); + my $r2 = $r->Radiobutton( + -anchor => 'w', + -text => 'The Color Green', + -value => 1, + -variable => \$photo2_use_bg, + -width => 20, + ); + $r2->pack( qw/ -side bottom/ ); + $r1->pack( qw/ -side bottom/ ); + + my $b = $controls->Button( + -command => [ \&photo2_blend, $i1, $i2, $i3, $dx, $dy, \$svar ], + -text => 'Composite ==>>', + ); + + my $l = $results->Label( -image => $i3 ); + + $tf->pack; + $bf->pack( qw/-fill both -expand 1/ ) ; + $b->pack( qw/ -side bottom -fill x/ ); + $s->pack( qw/ -side left -fill both -expand 1 / ); + $spacer->pack( qw/ -side left -fill y -expand 1 / ); + $rt->pack( qw/ -side top / ); + $r->pack( qw/ -side right / ); + $l->pack( qw/ -side right / ); + +} # end photo2 + +sub photo2_blend { + + my( $img1, $img2, $img3, $dx, $dy, $svar_ref ) = @_; + + my $a2 = $$svar_ref / 100.0; + my $a1 = 1.0 - $a2; + + my $width1 = $img1->width; + my $height1 = $img1->height; + my $width2 = $img2->width; + my $height2 = $img2->height; + + $img3->blank; + + my $x1 = $dx; + my $x2 = 0; + + for ( my $i = 0; $i < $width1; $i++ ) { + last if $i > $width2; + my $y1 = $dy; + my $y2 = 0; + + for ( my $j = 0; $j < $height1; $j++ ) { + last if $j > $height2; + + # Skip if no pixel at this coordinate or if transparent. Else, + # combine the proper percentage of each color component and + # put the pixel into the third image. + + Tk::catch { + if ( not $img2->transparencyGet( $x2, $y2 ) ) { + + my ( @c1 ) = $img1->get( $x1, $y1 ); + my ( @c2 ) = $img2->get( $x2, $y2 ); + + # You can use a colored background rather than another + # image to test alpha channels. Uncomment this line to + # ignore the first image and force a green backround. + @c1 = ( 0, 255, 0 ) if $photo2_use_bg; + + foreach my $c ( 0 .. 2 ) { + $c1[$c] = $c1[$c] * $a1 + $c2[$c] * $a2; + } + + my $color = sprintf( "#%02x%02x%02x", @c1[0 .. 2] ); + $img3->put( $color, -to => $x1, $y1 ); + + } # ifend + }; # catchend + + $y1++; + $y2++; + + } # forend $j + + $img3->update; + $x1++; + $x2++; + + } # forend $i + +} # end photo2_blend diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/plot.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/plot.pl new file mode 100755 index 00000000000..1f7d3d03904 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/plot.pl @@ -0,0 +1,28 @@ +# plot.pl + +use Plot; +use vars qw/$TOP/; + +sub plot { + + # Create a top-level window containing a canvas displaying a simple + # graph with data points that can be dragged with the pointing device. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1.\n\nYou can also select a printable area with the mouse button 2.", + -title => 'Plot Demonstration', + -iconname => 'plot', + ); + + my $c = $TOP->Plot( + -title_color => 'Brown', + -inactive_highlight => 'Skyblue2', + -active_highlight => 'red', + ); + $c->pack(qw/-fill x/); + +} # end plot + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/progress.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/progress.pl new file mode 100755 index 00000000000..5875ba1d2b8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/progress.pl @@ -0,0 +1,46 @@ +# ProgressBar - display various progress bars. + +use strict; +use Tk; +use Tk::ProgressBar; +use Tk::Scale; + +my $mw = MainWindow->new; + +my $status_var = 0; + +my($fromv,$tov) = (0,100); +foreach my $loop (0..1) { + my $res = 0; + my $blks = 10; + my @p = qw(top bottom left right); + foreach my $dir (qw(n s w e)) { + $mw->ProgressBar( + -borderwidth => 2, + -relief => 'sunken', + -width => 20, + -padx => 2, + -pady => 2, + -variable => \$status_var, + -colors => [0 => 'green', 50 => 'yellow' , 80 => 'red'], + -resolution => $res, + -blocks => $blks, + -anchor => $dir, + -from => $fromv, + -to => $tov + )->pack( + -padx => 10, + -pady => 10, + -side => pop(@p), + -fill => 'both', + -expand => 1 + ); + $blks = abs($blks - ($res * 2)); + $res = abs(5 - $res); + } + ($fromv,$tov) = ($tov,$fromv); +} + +$mw->Scale(-from => 0, -to => 100, -variable => \$status_var)->pack; + +MainLoop; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/puzzle.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/puzzle.pl new file mode 100755 index 00000000000..43910eca7e2 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/puzzle.pl @@ -0,0 +1,86 @@ +# puzzle.pl + +use subs qw/puzzle_switch/; +use vars qw/$TOP/; + +sub puzzle { + + # Create a top-level window containing a 15-puzzle game. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right.', + -title => '15-Puzzle Demonstration', + -iconname => 'puzzle', + ); + + # Special trick: select a darker color for the space by creating a + # scrollbar widget and using its trough color. + + my $s = $TOP->Scrollbar; + my $frame = $TOP->Frame( + -width => 120, + -height => 120, + -borderwidth => '2', + -relief => 'sunken', + -background => $s->cget(-troughcolor), + ); + $frame->pack(qw/-side top -padx 1c -pady 1c/); + $s->destroy; + + my(@order) = (3, 1, 6, 2, 5, 7, 15, 13, 4, 11, 8, 9, 14, 10, 12); + my %xpos = (); + my %ypos = (); + + my($i, $num, $frame_num); + for ($i=0; $i<15; $i++) { + $num = $order[$i]; + $xpos{$num} = ($i%4) * 0.25; + $ypos{$num} = (int($i/4)) * 0.25; + $frame_num = $frame->Button( + -relief => 'raised', + -text => $num, + -highlightthickness => 0, + ); + $frame_num->configure( + -command => [\&puzzle_switch, $frame_num, $num, \%xpos, \%ypos], + ); + $frame_num->place( + -relx => $xpos{$num}, + -rely => $ypos{$num}, + -relwidth => 0.25, + -relheight => 0.25, + ); + } # forend all puzzle numbers + $xpos{'space'} = 0.75; + $ypos{'space'} = 0.75; + +} # end puzzle + +sub puzzle_switch { + + # Procedure invoked by buttons in the puzzle to resize the puzzle entries. + + my($w, $num, $xpos, $ypos) = @_; + + if ( (($ypos->{$num} >= ($ypos->{'space'} - 0.01)) && + ($ypos->{$num} <= ($ypos->{'space'} + 0.01)) + && ($xpos->{$num} >= ($xpos->{'space'} - 0.26)) && + ($xpos->{$num} <= ($xpos->{'space'} + 0.26))) + || (($xpos->{$num} >= ($xpos->{'space'} - 0.01)) && + ($xpos->{$num} <= ($xpos->{'space'} + 0.01)) + && ($ypos->{$num} >= ($ypos->{'space'} - 0.26)) && + ($ypos->{$num} <= ($ypos->{'space'} + 0.26))) ) { + my $tmp = $xpos->{'space'}; + $xpos->{'space'} = $xpos->{$num}; + $xpos->{$num} = $tmp; + $tmp = $ypos->{'space'}; + $ypos->{'space'} = $ypos->{$num}; + $ypos->{$num} = $tmp; + $w->place(-relx => $xpos->{$num}, -rely => $ypos->{$num}); + } + +} # end puzzle_switch + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/radio.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/radio.pl new file mode 100755 index 00000000000..bae8c9daf3e --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/radio.pl @@ -0,0 +1,78 @@ +# radio.pl + +use Tk::widgets qw/LabFrame/; +use vars qw/$TOP/; + +sub radio { + + # Create a top-level window that displays a bunch of radio buttons. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Perl variable is associated with each group to indicate which of the group\'s buttons is selected. Click the "See Variables" button to see the current values of the variables.', qw/-wraplength 5i/], + -title => 'Radiobutton Demonstration', + -iconname => 'radio', + ); + + my $var = $TOP->Button( + -text => 'See Variables', + -command => [\&see_vars, $TOP, [ + ['point size', \$POINT_SIZE], + ['color', \$COLOR], + ['alignment', \$ALIGN], + ] + ], + ); + $var->pack(qw/-side bottom -expand 1/); + + my @pl = qw/-side left -expand 1 -padx .5c -pady .5c/; + my $left = $TOP->LabFrame(-label => 'Point Size')->pack(@pl); + my $mid = $TOP->LabFrame(-label => 'Color')->pack(@pl); + my $right = $TOP->LabFrame(-label => 'Alignment')->pack(@pl); + + @pl = qw/-side top -pady 2 -anchor w/; + foreach my $p (10, 12, 18, 24) { + $left->Radiobutton( + -text => "Point Size $p", + -variable => \$POINT_SIZE, + -relief => 'flat', + -value => $p, + )->pack(@pl); + } + + foreach my $c (qw/Red Green Blue Yellow Orange Purple/) { + $mid->Radiobutton( + -text => $c, + -variable => \$COLOR, + -relief => 'flat', + -value => lc($c), + -command => sub {$mid->configure(-foreground => $c)}, + )->pack(@pl); + } + + my $l = $right->Label(qw/-text Label -bitmap questhead -compound left/); + $l->configure(-width => $l->reqwidth, -compound => 'top'); + $l->configure(-height => $l->reqheight); + my %w; + foreach my $a (qw/Top Left Right Bottom/) { + my $lower = lc $a; + $w{$lower} = $right->Radiobutton( + -text => $a, + -variable => \$ALIGN, + -relief => 'flat', + -value => $lower, + -indicatoron => 0, + -width => 7, + -command => sub { + $l->configure(-compound => $ALIGN); + }, + ); + } + Tk::grid('x', $w{'top'}); + $w{'left'}->grid($l, $w{'right'}); + Tk::grid('x', $w{'bottom'}); + +} # end radio + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ruler.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ruler.pl new file mode 100755 index 00000000000..83e946f06e5 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/ruler.pl @@ -0,0 +1,146 @@ +# ruler.pl + +use subs qw/ruler_make_tab ruler_move_tab ruler_new_tab ruler_release_tab + ruler_select_tab/; +use vars qw/$TOP/; + +sub ruler { + + # Create a canvas demonstration consisting of a ruler displays a ruler + # with tab stops that can be set individually. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button.', qw/-wraplength 5i/], + -title => 'Ruler Demonstration', + -iconname => 'ruler', + ); + + my $c = $TOP->Canvas(qw/-width 14.8c -height 2.5c/); + $c->pack(qw/-side top -fill x/); + + my %rinfo; # ruler information hash + $rinfo{grid} = '.25c'; + $rinfo{left} = $c->fpixels('1c'); + $rinfo{right} = $c->fpixels('13c'); + $rinfo{top} = $c->fpixels('1c'); + $rinfo{bottom} = $c->fpixels('1.5c'); + $rinfo{size} = $c->fpixels('.2c'); + $rinfo{normalStyle} = [qw/-fill black/]; + if ($TOP->depth > 1) { + $rinfo{activeStyle} = [qw/-fill red -stipple/ => undef]; + $rinfo{deleteStyle} = [ + -fill => 'red', + -stipple => '@'.Tk->findINC('demos/images/grey.25'), + ]; + } else { + $rinfo{activeStyle} = [qw/-fill black -stipple/ => undef]; + $rinfo{deleteStyle} = [ + -fill => 'black', + -stipple => '@'.Tk->findINC('demos/images/grey.25'), + ]; + } + + $c->create(qw/line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1/); + my $i; + for ($i = 0; $i < 12; $i++) { + my $x = $i+1; + $c->create('line', "$x.c", '1c', "$x.c", '0.6c', -width => 1); + $c->create('line', "$x.25c", '1c', "$x.25c", '0.8c', -width => 1); + $c->create('line', "$x.5c", '1c', "$x.5c", '0.7c', -width => 1); + $c->create('line', "$x.75c", '1c', "$x.75c", '0.8c', -width => 1); + $c->create('text', "$x.15c", '.75c',-text => $i, -anchor => 'sw'); + } + $c->addtag('well', 'withtag', $c->create(qw/rect 13.2c 1c 13.8c 0.5c + -outline black -fill/, ($c->configure(-bg))[4])); + $c->addtag('well', 'withtag', ruler_make_tab($c, $c->pixels('13.5c'), + $c->pixels('.65c'), \%rinfo)); + + $c->bind('well', '<1>' => [\&ruler_new_tab, \%rinfo]); + $c->bind('tab', '<1>' => [\&ruler_select_tab, \%rinfo]); + $c->Tk::bind('<B1-Motion>' => [\&ruler_move_tab, \%rinfo]); + $c->Tk::bind('<Any-ButtonRelease-1>', [\&ruler_release_tab, \%rinfo]); + +} # end ruler + +sub ruler_make_tab { + + my($c, $x, $y, $rinfo) = @_; + + return $c->create('polygon', $x, $y, $x+$rinfo->{size}, $y+$rinfo->{size}, + $x-$rinfo->{size}, $y+$rinfo->{size}); + +} # end ruler_make_tab + +sub ruler_move_tab { + + my($c, $rinfo) = @_; + + return if not defined $c->find('withtag', 'active'); + my $e = $c->XEvent; + my($x, $y) = ($e->x, $e->y); + my $cx = $c->canvasx($x, $rinfo->{grid}); + my $cy = $c->canvasy($y); + if ($cx < $rinfo->{left}) { + $cx = $rinfo->{left}; + } + if ($cx > $rinfo->{right}) { + $cx = $rinfo->{right}; + } + if (($cy >= $rinfo->{top}) and ($cy <= $rinfo->{bottom})) { + $cy = $rinfo->{top} + 2; + $c->itemconfigure('active', @{$rinfo->{activeStyle}}); + } else { + $cy = $cy - $rinfo->{size} - 2; + $c->itemconfigure('active', @{$rinfo->{deleteStyle}}); + } + $c->move('active', $cx-$rinfo->{'x'}, $cy-$rinfo->{'y'}); + $rinfo->{'x'} = $cx; + $rinfo->{'y'} = $cy; + +} # end ruler_move_tab + +sub ruler_new_tab { + + my($c, $rinfo) = @_; + + my $e = $c->XEvent; + my($x, $y) = ($e->x, $e->y); + $c->addtag('active', 'withtag', ruler_make_tab($c, $x, $y, $rinfo)); + $c->addtag('tab', 'withtag', 'active'); + $rinfo->{'x'} = $x; + $rinfo->{'y'} = $y; + ruler_move_tab($c, $rinfo); + +} # end ruler_new_tab + +sub ruler_release_tab { + + my($c, $rinfo) = @_; + + return if not defined $c->find('withtag', 'active'); + if ($rinfo->{'y'} != $rinfo->{top} + 2) { + $c->delete('active'); + } else { + $c->itemconfigure('active', @{$rinfo->{normalStyle}}); + $c->dtag('active'); + } + +} # end ruler_release_tab + +sub ruler_select_tab { + + my($c, $rinfo) = @_; + + my $e = $c->XEvent; + my($x, $y) = ($e->x, $e->y); + $rinfo->{'x'} = $c->canvasx($x, $rinfo->{grid}); + $rinfo->{'y'} = $rinfo->{top} + 2; + $c->addtag('active', 'withtag', 'current'); + $c->itemconfigure('active', @{$rinfo->{activeStyle}}); + $c->raise('active'); + +} # end ruler_select_tab + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/sayings.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/sayings.pl new file mode 100755 index 00000000000..cd9ec5bd898 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/sayings.pl @@ -0,0 +1,48 @@ +# sayings.pl + +use vars qw/$TOP/; + +sub sayings { + + # Create a top-level window containing a listbox with a bunch of + # well-known sayings. The listbox can be scrolled or scanned in + # two dimensions. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed.', + -title => 'Listbox Demonstration (well-known sayings)', + -iconname => 'sayings', + ); + + my $list = $TOP->Scrolled(qw/Listbox -width 20 -height 10 -setgrid 1 + -scrollbars se/); + $list->pack(qw/-expand yes -fill y/); + $list->focus; + + $list->insert(0, + 'Waste not, want not', + 'Early to bed and early to rise makes a man healthy, wealthy, and wise', + 'Ask not what your country can do for you, ask what you can do for your country', + 'I shall return', + 'NOT', + 'A picture is worth a thousand words', + 'User interfaces are hard to build', + 'Thou shalt not steal', + 'A penny for your thoughts', + 'Fool me once, shame on you; fool me twice, shame on me', + 'Every cloud has a silver lining', + 'Where there\'s smoke there\'s fire', + 'It takes one to know one', + 'Take this job and shove it', + 'Up a creek without a paddle', + 'I\'m mad as hell and I\'m not going to take it any more', + 'An apple a day keeps the doctor away', + 'Don\'t look a gift horse in the mouth'); + + $list->activate(0); + +} # end sayings + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/search.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/search.pl new file mode 100755 index 00000000000..ddc42213a0f --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/search.pl @@ -0,0 +1,177 @@ +# search.pl + +use Tk::LabEntry; +use subs qw/search_flash_matches search_load_file search_text/; +use vars qw/$TOP/; + +sub search { + + # Create a top-level window with a text widget that allows you to load a + # file and highlight all instances of a given string. A LabEntry widget + # is used to collect the file name and search string. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text =>'', + -title => 'Text Demonstration - Search and Highlight', + -iconname => 'search', + ); + + my $file_name = ''; + my $file = $TOP->Frame; + my $fn = $file->LabEntry(-label => 'File Name: ', -width => 40, + -labelPack => [qw/-side left -anchor w/], + -textvariable => \$file_name)->pack(qw/-side left/); + $fn->Subwidget('entry')->focus; + my $fn_button = $file->Button(-text => 'Load File'); + $fn_button->pack(qw/-side left -pady 5 -padx 10/); + + my $search_string = ''; + my $kind = 'exact'; + my $string = $TOP->Frame; + my $ss = $string->LabEntry(-label => 'Search string:', -width => 40, + -labelPack => [qw/-side left -anchor w/], + -textvariable => \$search_string)->pack(qw/-side left/); + my $ss_button = $string->Button(-text => 'Highlight'); + $ss_button->pack(qw/-side left -pady 5 -padx 10/); + + my $text = $TOP->Scrolled(qw/Text -setgrid true -scrollbars e/); + + my $subframe = $TOP->Frame; + my $exact = $subframe->Radiobutton(-text => 'Exact match', + -variable => \$kind, + -value => 'exact'); + my $regexp = $subframe->Radiobutton(-text => 'Regular expression', + -variable => \$kind, + -value => 'regexp'); + $exact->pack(qw/-side left/, -fill => 'x'); + $regexp->pack(qw/-side right/, -fill => 'x'); + + $file->pack(qw/-side top -fill x/); + $string->pack(qw/-side top -fill x/); + $subframe->pack(qw/-side top -fill x/); + $text->pack(qw/-expand yes -fill both/); + + my $command = sub {search_load_file $text, \$file_name, $ss}; + $fn_button->configure(-command => $command); + $fn->bind('<Return>' => $command); + + $command = sub {search_text $text, \$search_string, 'search', $kind}; + $ss_button->configure(-command => $command); + $ss->bind('<Return>' => $command); + + # Set up display styles for text highlighting. + + if ($TOP->depth > 1) { + search_flash_matches $text, + ['configure', 'search', + -background => '#ce5555', -foreground => 'white'], 800, + ['configure', 'search', + -background => undef, -foreground => undef], 200; + } else { + search_flash_matches $text, + ['configure', 'search', + -background => 'black', -foreground => 'white'], 800, + ['configure', 'search', + -background => undef, -foreground => undef], 200; + } + + $text->insert('0.0', 'This window demonstrates how to use the tagging facilities in text +widgets to implement a searching mechanism. First, type a file name +in the top entry, then type <Return> or click on "Load File". Then +type a string in the lower entry and type <Return> or click on +"Highlight". This will cause all of the instances of the string to +be tagged with the tag "search", and it will arrange for the tag\'s +display attributes to change to make all of the strings blink.'); + + $text->mark(qw/set insert 0.0/); + +} # end search + +sub search_flash_matches { + + # The procedure below is invoked repeatedly to invoke two commands at + # periodic intervals. It normally reschedules itself after each execution + # but if an error occurs (e.g. because the window was deleted) then it + # doesn't reschedule itself. + # Arguments: + # + # w - Text widget reference. + # cmd1 - Reference to a list of tag options. + # sleep1 - Ms to sleep after executing cmd1 before executing cmd2. + # cmd2 - Reference to a list of tag options. + # sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. + + my($w, $cmd1, $sleep1, $cmd2, $sleep2) = @_; + + $w->tag(@{$cmd1}); + $w->after($sleep1, + [\&search_flash_matches, $w, $cmd2, $sleep2, $cmd1, $sleep1]); + +} # end search_flash_matches + +sub search_load_file { + + # The utility procedure below loads a file into a text widget, discarding + # the previous contents of the widget. Tags for the old widget are not + # affected, however. + # Arguments: + # + # w - The window into which to load the file. Must be a text widget. + # file - Reference to the name of the file to load. Must be readable. + # e - Entry widget to get next focus. + + my ($w, $file, $e) = @_; + + my ($buf, $bytes) = ('', 0); + + if (not open(F, "<$$file")) { + $MW->Dialog( + -title => 'File Not Found', + -text => "$!: '$$file'", + -bitmap => 'error', + )->Show; + return; + } + $w->delete(qw/1.0 end/); + $bytes = read F, $buf, 10_000; # after all, it IS just an example + $w->insert('end', $buf); + if ($bytes == 10000) { + $w->insert('end', "\n\n**************** File truncated at 10,000 bytes! ****************\n"); + } + close F; + + $e->Subwidget('entry')->focus; + +} # end search_load_file + +sub search_text { + + # The utility procedure below searches for all instances of a given + # string in a text widget and applies a given tag to each instance found. + # Arguments: + # + # w - The window in which to search. Must be a text widget. + # string - Reference to the string to search for. The search is done + # using exact matching only; no special characters. + # tag - Tag to apply to each instance of a matching string. + + my($w, $string, $tag, $kind) = @_; + + return unless ref($string) && length($$string); + + $w->tagRemove($tag, qw/0.0 end/); + my($current, $length) = ('1.0', 0); + + while (1) { + $current = $w->search(-count => \$length, "-$kind", $$string, $current, 'end'); + last if not $current; + warn "Posn=$current count=$length\n", + $w->tagAdd($tag, $current, "$current + $length char"); + $current = $w->index("$current + $length char"); + } + +} # end search_text + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/showVars.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/showVars.pl new file mode 100755 index 00000000000..0130ccd153b --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/showVars.pl @@ -0,0 +1,37 @@ + + +sub showVars { + + # Create a top-level window that displays a bunch of global variable values + # and keeps the display up-to-date even when the variables change value. + # + # Arguments: + # w - Perl widget reference of parent. + # vars - Name of variable(s) to monitor. + + $showVars->destroy if Exists($showVars); + $showVars = shift->Toplevel(); + my $w = $showVars; + dpos($w); + $w->title('Variable values'); + $w->iconname('Variables'); + + my $w_title = $w->Label(-text => 'Variable values:', -width => 20, -anchor, 'center', + -font => '-Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-*'); + $w_title->pack(-fill => 'x'); + my $i; + foreach $i (@_) { + my $w_i = $w->Frame(); + my $w_i_name = $w_i->Label(-text => "$i: "); + my $w_i_value = $w_i->Label(-textvariable => \${$i}); + $w_i_name->pack(-side => 'left'); + $w_i_value->pack(-side => 'left'); + $w_i->pack(-side => 'top', -anchor => 'w'); + } + $w->Button(-text => 'OK', -command => [$w => 'destroy'])-> + pack(-side => 'bottom', -pady => 2); + +} # end showVars + + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/slide.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/slide.pl new file mode 100755 index 00000000000..7bd31a0b369 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/slide.pl @@ -0,0 +1,178 @@ +# slide.pl + +$Tk::SlideSwitch::VERSION = '1.1'; + +package Tk::SlideSwitch; + +use Tk; +use Tk::widgets qw/Label Scale/; +use base qw/Tk::Frame/; +use strict; + +Construct Tk::Widget 'SlideSwitch'; + +sub Populate { + + my($self, $args) = @_; + + $self->SUPER::Populate($args); + + my $ll = $self->Label->pack(-side => 'left'); + my $sl = $self->Scale->pack(-side => 'left'); + my $rl = $self->Label->pack(-side => 'left'); + + $self->ConfigSpecs( + -command => [$sl, qw/command Command /], + -from => [$sl, qw/from From 0/], + -highlightthickness => [$sl, + qw/highlightThickness HighlightThickness 0/], + -length => [$sl, qw/length Length 30/], + -llabel => [qw/METHOD llabel Llabel /], + -orient => [$sl, qw/orient Orient horizontal/], + -rlabel => [qw/METHOD rlabel Rlabel /], + -showvalue => [$sl, qw/showValue ShowValue 0/], + -sliderlength => [$sl, qw/sliderLength SliderLength 15/], + -sliderrelief => [$sl, qw/sliderRelief SliderRelief raised/], + -to => [$sl, qw/to To 1/], + -troughcolor => [$sl, qw/troughColor TroughColor /], + -width => [$sl, qw/width Width 8/], + -variable => [$sl, qw/variable Variable /], + 'DEFAULT' => [$ll, $rl], + ); + + $self->{ll} = $ll; + $self->{sl} = $sl; + $self->{rl} = $rl; + + $self->bind('<Configure>' => sub { + my ($self) = @_; + my $orient = $self->cget(-orient); + return if $orient eq 'horizontal'; + my ($ll, $sl, $rl) = ($self->{ll}, $self->{sl}, $self->{rl}); + $ll->packForget; + $sl->packForget; + $rl->packForget; + $ll->pack; + $sl->pack; + $rl->pack; + }); + +} # end Populate + +# Private methods and subroutines. + +sub llabel { + my ($self, $args) = @_; + $self->{ll}->configure(@$args); +} # end llabel + +sub rlabel { + my ($self, $args) = @_; + $self->{rl}->configure(@$args); +} # end rlabel + +1; + +package main; + +use vars qw / $TOP /; +use strict; + +sub slide { + + my( $demo ) = @_; + + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => "This demonstration creates a new composite SlideSwitch widget that can be either on or off. The widget is really a customized Scale widget.", + -title => 'A binary sliding switch', + -iconname => 'slide', + ); + + my $mw = $TOP; + + my $sl = $mw->SlideSwitch( + -bg => 'gray', + -orient => 'horizontal', + -command => sub {print "Switch value is @_\n"}, + -llabel => [-text => 'OFF', -foreground => 'blue'], + -rlabel => [-text => 'ON', -foreground => 'blue'], + -troughcolor => 'tan', + )->pack(qw/-side left -expand 1/); + +} # end slide + +__END__ + +=head1 NAME + +Tk::SlideSwitch - a 2 position horizontal or vertical switch. + +=head1 SYNOPSIS + + use Tk::SlideSwitch; + + my $sl = $frame1->SlideSwitch( + -bg => 'gray', + -orient => 'horizontal', + -command => [$self => 'on'], + -llabel => [-text => 'OFF', -foreground => 'blue'], + -rlabel => [-text => 'ON', -foreground => 'blue'], + -troughcolor => 'tan', + )->pack(qw/-side left -expand 1/); + +=head1 DESCRIPTION + +Tk::SlideSwitch is a Frame based composite mega-widget featuring a binary Scale +widget surrounded by two Label widgets. The Scale's value can be either 0 or +1. The Labels are positioned to the left and right of the Scale if its +orientation is horizontal, else on the top and bottom of the Scale. + +=head1 OPTIONS + +In addition to all Scale options, the following option/value pairs are +also supported: + +=over 4 + +=item B<-llabel> + +A reference to an array of left (or top) Label configuration options. + +=item B<-rlabel> + +A reference to an array of right (or bottom) Label configuration options. + +=back + +=head1 METHODS + +There are no special methods. + +=head1 ADVERTISED WIDGETS + +Component subwidgets can be accessed via the B<Subwidget> method. +This mega widget has no advertised subwidgets. + +=head1 EXAMPLE + +See Synopsis. + +=head1 BUGS + +This widget uses only the pack geometry manager. + +=head1 AUTHOR + +sol0@Lehigh.EDU + +Copyright (C) 2002 - 2003, Steve Lidie. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 KEYWORDS + +SlideSwitch, Scale + +=cut diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/spin.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/spin.pl new file mode 100755 index 00000000000..f9b8c05a891 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/spin.pl @@ -0,0 +1,36 @@ +# spin.pl + +use vars qw/$TOP/; + +sub spin { + + # This demonstration script creates several spinbox widgets. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['Three different spin-boxes are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For values that are too large to fit in the window all at once, you can scan through the value by dragging with mouse button2 pressed. Note that the first spin-box will only permit you to type in integers, and the third selects from a list of Australian cities.', + -wraplength => '5i'], + -title => 'Spinbox Demonstration', + -iconname => 'spin', + ); + + my $s1 = $TOP->Spinbox( + qw/-from 1 -to 10 -width 10 -validate key/, + -validatecommand => sub { + my ($proposed, $changes, $current, $index, $type) = @_; + return not $proposed =~ m/[^\d]/g; + }, + ); + my $s2 = $TOP->Spinbox( + qw/-from 0 -to 3 -increment .5 -format %05.2f -width 10/, + ); + my $s3 = $TOP->Spinbox( + -values => [qw/Canberra Sydney Melbourne Perth Adelaide Brisbane Hobart + Darwin/, 'Alice Springs'], + -width => 10, + ); + + $s1->pack($s2, $s3, qw/-side top -pady 5 -padx 10/); + +} # end spin.pl diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/states.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/states.pl new file mode 100755 index 00000000000..b9b350df952 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/states.pl @@ -0,0 +1,28 @@ +# states.pl + +use vars qw/$TOP/; + +sub states { + + # Create a top-level window that displays a listbox with the names of the + # 50 states. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by scanning. To scan, press button 2 in the widget and drag up or down.', + -title => 'Listbox Demonstration (50 states)', + -iconname => 'states', + ); + + my $list = $TOP->Scrolled(qw/Listbox -setgrid 1 -height 12 -scrollbars e/); + $list->pack(qw/-side left -expand yes -fill both/); + $list->focus; + + $list->insert(0, qw/Alabama Alaska Arizona Arkansas California Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois Indiana Iowa Kansas Kentucky Louisiana Maine Maryland Massachusetts Michigan Minnesota Mississippi Missouri Montana Nebraska Nevada/, 'New Hampshire', 'New Jersey', 'New Mexico', 'New York', 'North Carolina', 'North Dakota', qw/Ohio Oklahoma Oregon Pennsylvania/, 'Rhode Island', 'South Carolina', 'South Dakota', qw/Tennessee Texas Utah Vermont Virginia Washington/, 'West Virginia', 'Wisconsin', 'Wyoming'); + + $list->activate(0); + +} # end states + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/style.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/style.pl new file mode 100755 index 00000000000..d7fd82112ea --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/style.pl @@ -0,0 +1,154 @@ +# style.pl + +use vars qw/$TOP/; + +sub style { + + # Create a top-level window with a text widget that demonstrates + # the various display styles that are available in texts. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text =>'', + -title => 'Text Demonstration - Display Styles', + -iconname => 'style', + ); + + eval { # eval, in case fonts already exist + $TOP->fontCreate(qw/C_small -family courier -size 10/); + $TOP->fontCreate(qw/C_big -family courier -size 14 -weight bold/); + $TOP->fontCreate(qw/C_vbig -family helvetica -size 24 -weight bold/); + $TOP->fontCreate(qw/C_bold -family courier -size 12 -weight bold + -slant italic/); + }; + + my $t = $TOP->Scrolled(qw/Text -setgrid true -width 70 -height 32 + -font normal -wrap word -scrollbars e/); + $t->pack(qw/-expand yes -fill both/); + + # Set up display styles. + + $t->tag(qw/configure bold -font C_bold/); + $t->tag(qw/configure big -font C_big/); + $t->tag(qw/configure verybig -font C_vbig/); + if ($TOP->depth > 1) { + $t->tag(qw/configure color1 -background/ => '#a0b7ce'); + $t->tag(qw/configure color2 -foreground red/); + $t->tag(qw/configure raised -relief raised -borderwidth 1/); + $t->tag(qw/configure sunken -relief sunken -borderwidth 1/); + } else { + $t->tag(qw/configure color1 -background black -foreground white/); + $t->tag(qw/configure color2 -background black -foreground white/); + $t->tag(qw/configure raised -background white -relief raised -bd 1/); + $t->tag(qw/configure sunken -background white -relief sunken -bd 1/); + } + $t->tag(qw/configure bgstipple -background black -borderwidth 0 + -bgstipple gray12/); + $t->tag(qw/configure fgstipple -fgstipple gray50/); + $t->tag(qw/configure underline -underline on/); + $t->tag(qw/configure overstrike -overstrike on/); + $t->tag(qw/configure right -justify right/); + $t->tag(qw/configure center -justify center/); + $t->tag(qw/configure super -offset 4p -font C_small/); + $t->tag(qw/configure sub -offset -2p -font C_small/); + $t->tag(qw/configure margins -lmargin1 12m -lmargin2 6m -rmargin 10m/); + $t->tag(qw/configure spacing -spacing1 10p -spacing2 2p + -lmargin1 12m -lmargin2 6m -rmargin 10m/); + + $t->insert('0.0', 'Text widgets like this one allow you to display ' . + 'information in a variety of styles. Display styles are ' . + 'controlled using a mechanism called '); + $t->insert('insert', 'tags', 'bold'); + $t->insert('insert', '. Tags are just textual names that you can apply ' . + 'to one or more ranges of characters within a text widget. ' . + 'You can configure tags with various display styles. If ' . + 'you do this, then the tagged characters will be displayed ' . + 'with the styles you chose. The available display styles ' . + 'are: '); + $t->insert('insert', "\n\n1. Font.", 'big'); + $t->insert('insert', ' You can choose any X font, '); + $t->insert('insert', 'large', 'verybig'); + $t->insert('insert', ' or small.'); + $t->insert('insert', "\n\n2. Color.", 'big'); + $t->insert('insert', ' You can change either the '); + $t->insert('insert', 'background', 'color1'); + $t->insert('insert', ' or '); + $t->insert('insert', 'foreground', 'color2'); + $t->insert('insert', "\ncolor, or "); + $t->insert('insert', 'both', ['color1', 'color2']); + $t->insert('insert', '.'); + $t->insert('insert', "\n\n3. Stippling.", 'big'); + $t->insert('insert', ' You can cause either the '); + $t->insert('insert', 'background', 'bgstipple'); + $t->insert('insert', ' or '); + $t->insert('insert', 'foreground', 'fgstipple'); + $t->insert('insert', "\ninformation to be drawn with a stipple fill instead of a solid fill."); + $t->insert('insert', "\n\n4. Underlining.", 'big'); + $t->insert('insert', ' You can '); + $t->insert('insert', 'underline', 'underline'); + $t->insert('insert', ' ranges of text.'); + $t->insert('insert', "\n\n5. Overstrikes.", 'big'); + $t->insert('insert', " You can "); + $t->insert('insert', "draw lines through", 'overstrike'); + $t->insert('insert', " ranges of text."); + $t->insert('insert', "\n\n6. 3-D effects.", ' big'); + $t->insert('insert', " You can arrange for the background to be drawn "); + $t->insert('insert', 'with a border that makes characters appear either '); + $t->insert('insert', 'raised', 'raised'); + $t->insert('insert', ' or '); + $t->insert('insert', 'sunken', 'sunken'); + $t->insert('insert', '.'); + $t->insert('insert', "\n\n7. Justification.", 'big'); + $t->insert('insert', " You can arrange for lines to be displayed\n"); + $t->insert('insert', "left-justified,\n"); + $t->insert('insert', "right-justified, or\n", 'right'); + $t->insert('insert', "centered.", 'center'); + $t->insert('insert', "\n\n8. Superscripts and subscripts." , 'big'); + $t->insert('insert', " You can control the vertical "); + $t->insert('insert', "position of text to generate superscript effects " . + "like 10"); + $t->insert('insert', "n", 'super'); + $t->insert('insert', " or subscript effects like X"); + $t->insert('insert', "i", 'sub'); + $t->insert('insert', "."); + $t->insert('insert', "\n\n9. Margins.", 'big'); + $t->insert('insert', " You can control the amount of extra space left"); + $t->insert('insert', " on\neach side of the text:\n"); + $t->insert('insert', "This paragraph is an example of the use of ", 'margins'); + $t->insert('insert', "margins. It consists of a single line of text ", 'margins'); + $t->insert('insert', "that wraps around on the screen. There are two ", 'margins'); + $t->insert('insert', "separate left margin values, one for the first ", 'margins'); + $t->insert('insert', "display line associated with the text line, ", 'margins'); + $t->insert('insert', "and one for the subsequent display lines, which ", 'margins'); + $t->insert('insert', "occur because of wrapping. There is also a ", 'margins'); + $t->insert('insert', "separate specification for the right margin, ", 'margins'); + $t->insert('insert', "which is used to choose wrap points for lines.", 'margins'); + + $t->insert('insert', "\n\n10. Spacing.", 'big'); + $t->insert('insert', " You can control the spacing of lines with three "); + $t->insert('insert', "separate parameters. \"Spacing1\" tells how much "); + $t->insert('insert', "extra space to leave\nabove a line, \"spacing3\" "); + $t->insert('insert', "tells how much space to leave below a line,\nand "); + $t->insert('insert', "if a text line wraps, \"spacing2\" tells how much "); + $t->insert('insert', "space to leave\nbetween the display lines that "); + $t->insert('insert', "make up the text line.\n"); + $t->insert('insert', "These indented paragraphs illustrate how spacing ", 'spacing'); + $t->insert('insert', "can be used. Each paragraph is actually a ", 'spacing'); + $t->insert('insert', "single line in the text widget, which is ", 'spacing'); + $t->insert('insert', "word-wrapped by the widget.\n", 'spacing'); + $t->insert('insert', "Spacing1 is set to 10 points for this text, ", 'spacing'); + $t->insert('insert', "which results in relatively large gaps between ", 'spacing'); + $t->insert('insert', "the paragraphs. Spacing2 is set to 2 points, ", 'spacing'); + $t->insert('insert', "which results in just a bit of extra space ", 'spacing'); + $t->insert('insert', "within a pararaph. Spacing3 isn't used ", 'spacing'); + $t->insert('insert', "in this example.\n", 'spacing'); + $t->insert('insert', "To see where the space is, select ranges of ", 'spacing'); + $t->insert('insert', "text within these paragraphs. The selection ", 'spacing'); + $t->insert('insert', "highlight will cover the extra space.", 'spacing'); + + $t->mark(qw/set insert 0.0/); + +} # end style + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/texts.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/texts.pl new file mode 100755 index 00000000000..3a2dc0115d8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/texts.pl @@ -0,0 +1,71 @@ +# texts.pl + +use vars qw/$TOP/; + +sub texts { + + # Create a top-level window that displays a basic text widget. + + my ($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => '', + -title => 'Text Demonstration - Basic Facilities', + -iconname => 'texts', + ); + + my $t = $TOP->Scrolled(qw/Text -relief sunken -borderwidth 2 -setgrid true + -height 30 -scrollbars e/); + $t->pack(qw/-expand yes -fill both/); + + $t->insert('0.0', 'This window is a text widget. It displays one or more lines of text +and allows you to edit the text. Here is a summary of the things you +can do to a text widget: + +1. Scrolling. Use the scrollbar to adjust the view in the text window. + +2. Scanning. Press mouse button 2 in the text window and drag up or down. +This will drag the text at high speed to allow you to scan its contents. + +3. Insert text. Press mouse button 1 to set the insertion cursor, then +type text. What you type will be added to the widget. + +4. Select. Press mouse button 1 and drag to select a range of characters. +Once you\'ve released the button, you can adjust the selection by pressing +button 1 with the shift key down. This will reset the end of the +selection nearest the mouse cursor and you can drag that end of the +selection by dragging the mouse before releasing the mouse button. +You can double-click to select whole words or triple-click to select +whole lines. + +5. Delete and replace. To delete text, select the characters you\'d like +to delete and type Backspace or Delete. Alternatively, you can type new +text, in which case it will replace the selected text. + +6. Copy the selection. To copy the selection into this window, select +what you want to copy (either here or in another application), then +click button 2 to copy the selection to the point of the mouse cursor. + +7. Edit. Text widgets support the standard Motif editing characters +plus many Emacs editing characters. Backspace and Control-h erase the +character to the left of the insertion cursor. Delete and Control-d +erase the character to the right of the insertion cursor. Meta-backspace +deletes the word to the left of the insertion cursor, and Meta-d deletes +the word to the right of the insertion cursor. Control-k deletes from +the insertion cursor to the end of the line, or it deletes the newline +character if that is the only thing left on the line. Control-o opens +a new line by inserting a newline character to the right of the insertion +cursor. Control-t transposes the two characters on either side of the +insertion cursor. + +7. Resize the window. This widget has been configured with the "setGrid" +option on, so that if you resize the window it will always resize to an +even number of characters high and wide. Also, if you make the window +narrow you can see that long lines automatically wrap around onto +additional lines so that all the information is always visible.'); + + $t->mark(qw/set insert 0.0/); + +} # end texts + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace1.pl new file mode 100755 index 00000000000..eba655c7ba0 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace1.pl @@ -0,0 +1,49 @@ +# trace1.pl + +use Tk::widgets qw/ Trace /; +use vars qw/ $TOP /; +use strict; + +sub trace1 { + + my( $demo ) = @_; + + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => "This demonstration animates an analog display as you move the Scale's slider.", + -title => 'Move a meter tied to a variable', + -iconname => 'trace1', + ); + + my $mw = $TOP; + my $v; # variable to trace + + my $c = $mw->Canvas(qw/-width 200 -height 110 -bd 2 -relief sunken/)->grid; + $c->createLine(qw/ 100 100 10 100 -tag meter -arrow last -width 5/); + my $s = $mw->Scale(qw/-orient h -from 0 -to 100 -variable/ => \$v)->grid; + $mw->Label(-text => 'Slide Me')->grid; + + # Trace $v when written. The callback is supplied three explicit arguments: + # the index if an array or hash, else undef, the proposed new value, and the + # trace operation (rwu) for read, write, undef, respectively. Additionally, + # we pass the Canvas and Scale widget references. + + $mw->traceVariable(\$v, 'w' => [\&trace1_update_meter, $c, $s]); + +} # end trace1 + +sub trace1_update_meter { + + my( $index, $value, $op, $c, $s ) = @_; + + return if $op eq 'u'; + + my($min, $max) = ($s->cget(-from), $s->cget(-to)); + my $pos = $value / abs($max - $min); + my $pi = 3.1415926; + my $x = 100.0 - 90.0 * (cos( $pos * $pi )); + my $y = 100.0 - 90.0 * (sin( $pos * $pi )); + $c->coords(qw/meter 100 100/, $x, $y); + return $value; + + } # end trace1_update_meter diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace2.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace2.pl new file mode 100755 index 00000000000..9d7c38806d5 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/trace2.pl @@ -0,0 +1,188 @@ +# trace2.pl + +$Tk::TraceText::VERSION = '1.0'; + +package Tk::TraceText; + +use Tk::widgets qw/ Trace /; +use base qw/ Tk::Derived Tk::Text /; +use strict; + +Construct Tk::Widget 'TraceText'; + +sub Populate { + + my( $self, $args ) = @_; + + $self->SUPER::Populate( $args ); + + $self->ConfigSpecs( + -textvariable => [ 'METHOD', 'textVariable', 'TextVariable', undef ], + ); + + $self->OnDestroy( sub { + my $vref = $self->{_vref}; + $self->traceVdelete ( $vref ) if defined $vref; + } ); + +} # end Populate + +# Private methods. + +sub insdel { + + my( $self, $sub, @args ) = @_; + + $self->{_busy} = 1; + $self->$sub( @args ); + my $vref = $self->{_vref}; + $$vref = $self->get( qw/1.0 end/ ); + $self->{_busy} = 0; + +} # end insedel + +sub textvariable { + + my ( $self, $vref ) = @_; + + $self->traceVariable( $vref, 'w', [ \&tracew => $self, $vref ] ); + $self->{_vref} = $vref; + +} # end textvariable + +sub tracew { + + my ( $index, $value, $op, $self, $vref ) = @_; + + return unless defined $self; # if app is being destroyed + return if $self->{_busy}; + + if ( $op eq 'w' ) { + $self->delete( qw/1.0 end/ ); + $self->insert( '1.0', $value ); + } elsif ( $op eq 'r' ) { + } elsif ( $op eq 'u' ) { + $self->traceVdelete ( $vref ); + } + +} # end tracew + +# Overridden methods. + +sub delete { + + my ( $self, @args ) = @_; + + $self->insdel( 'SUPER::delete', @args ) + +} # end delete + +sub insert { + + my ( $self, @args ) = @_; + + $self->insdel( 'SUPER::insert', @args ); + +} # end insert + +1; + +package main; + +use Tk::widgets qw/ Trace /; +use vars qw / $TOP /; +use strict; + +sub trace2 { + + my( $demo ) = @_; + + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => "This demonstration derives a new Text widget whose contents are modified using a normal Perl variable.", + -title => 'Contents of a Text widget tied to a variable', + -iconname => 'trace2', + ); + + my $mw = $TOP; + my $tt = $mw->Scrolled( 'TraceText', -textvariable => \my $frog )->grid; + $tt->focus; + + $mw->traceVariable( \$frog, 'wu', [ \&trace2_tracefrog, $mw, \$frog ] ); + + $frog = "Frogs lacking lipophores are blue."; + +} # end trace2 + +sub trace2_tracefrog { + + my( $index, $value, $op ) = @_; + + print "Final " if $op eq 'u'; + print "User trace: $value"; + return $value; + +} + +__END__ + +=head1 NAME + +Tk::TraceText - Text contents defined by a traced variable. + +=for pm Tk/TraceText.pm + +=for category Text + +=head1 SYNOPSIS + + $tt = $parent->TraceText(-option => value, ... ); + +=head1 DESCRIPTION + +Create a new B<TraceText> widget that is derived from the standard B<Text> +widget. Because it inherits all the base options and methods it behaves +just like a B<Text> widget. Additionally, B<TraceText> adds a -textvariable +option, which is a reference to a Perl scalar that defines the contents of +the widget. + +Based on the Tcl/Tk TracedText "overridden widget" by Kevin Kenny. + +=over 4 + +=item B<-textvariable> + +A scalar reference. The value of the variable defines the contents of the +TraceText widget. Using the keyboard to insert or delete text changes the +value of the variable, and changing the variable alters the contents of the +TraceText widget. + +=back + +=head1 METHODS + +Standard Text widget methods. + +=head1 ADVERTISED SUBWIDGETS + +None. + +=head1 EXAMPLE + + my $tt = $mw->TraceText( -textvariable => \$scalar ); + +=head1 AUTHOR + +Stephen.O.Lidie@Lehigh.EDU + +Copyright (C) 2003 - 2004, Steve Lidie. All rights reserved. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 KEYWORDS + +text, trace + +=cut + diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/transtile.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/transtile.pl new file mode 100755 index 00000000000..55e7130a1af --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/transtile.pl @@ -0,0 +1,113 @@ +# transtile.pl + +use vars qw/$TOP/; + +sub transtile { + + # Create a top-level window that demonstrates tiles + # and transparent stuff. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => ['This window demonstrates tiles and transparent images. The Canvas has a yellow background, which displays for one second before it\'s overlayed with a tile of tiny camels. On top of the tile layer are three non-transparent images that obscure the tile. Canvas items such as ovals, rectangles and polygons cannot react to bound events unless they are filled with a color - move the cursor over the blue circle and note that it reacts to <Motion> events. The transparent circle outlined in red to the left of the blue circle does not react to <Motion> events in its interior because it\'s transparent, or unfilled. If you need a transparent item that also reacts to events then add a transparent stipple. The bottom red circle is both transparent and aware of events. Finally, a blue lattice (a transparent GIF that\'s been Base64 encoded so it can be embedded in the source) is overlayed on top of everything, anchored to the southeast corner of the Canvas.', -wraplength => '8i'], + -title => 'Tile and Transparent Demonstration', + -iconname => 'transtile', + ); + + my $tile = $TOP->Photo(-file =>Tk->findINC('Camel.xpm')); + + # A tiled Canvas - the tile overlays the background color. + + my $c = $TOP->Canvas( + -background => 'yellow', + -width => 300, + -height => 250, + -relief => 'raised', + -borderwidth => 3, + )->grid; + $c->update; + $c->after(1000); + $c->configure(-tile => $tile); + + # These images are not transparent, thus they obscure the tile + # or background. + + my($x, $y) = (30, 30); + foreach (qw/Xcamel.gif anim.gif icon.gif/) { + $c->createImage($x, $y, -image => $TOP->Photo(-file => Tk->findINC($_))); + $x += 50; + $y += 50; + } + + # Transparent Canvas items do not generate events. + + my $cb = sub { + print "Over circle, args = @_!\n"; + }; + + # Not filled (transparent), no events. + + my $o1 = $c->createOval(25, 25, 100, 100, + -outline => 'red', + ); + $c->bind($o1, '<Motion>' => $cb); + + # Filled (non-transparent), but with events. + + my $o2 = $c->createOval(155, 25, 225, 100, + -outline => 'red', + -fill => 'blue', + ); + $c->bind($o2, '<Motion>' => $cb); + + # Transparently filled, with events. + + my $o3 = $c->createOval(25, 120, 100, 195, + -outline => 'red', + -fill => 'blue', + -stipple => 'transparent', + ); + $c->bind($o3, '<Motion>' => $cb); + + # A transparent GIF overlaying everything. + + $c->createImage(300, 300, + -image => $TOP->Photo(-data => &encoded_gif, -format => 'gif'), + -anchor => 'se', + ); + +} # end transtile + +sub encoded_gif { + + # A Base64 encoded transparent GIF. + + my $gif = <<'END_OF_GIF'; +R0lGODlhyADIAIAAAB0A/////yH+Dk1hZGUgd2l0aCBHSU1QACH5BAEKAAEALAAAAADIAMgAAAL+ +jI+py+0Po5y02ouz3rz7D4biSJbmiabqCgJuC7DZK9Ly5+Zdrt8Sb+MAYzDUkKgZ+n5AXNOjLB03 +R6TQmpxeo9seSTsDZ3ldctk7fo7EGC5VnQ6+zWd5CB6mx9Ft/N6p92WXBejXt4Z1trTI4MboM/i4 +6ChZabkUeam5ydnp+QkaKjpKWmp6ipqqusoKldjqWvOqSQmbx3ebSTiH+yZrZHhR+9c3bGFcgcwb +KMy2PBtR5cpc3DsdTCF9Tc3Efez8rUysWOgNId6NPaGNaJ6t3uweDV2t+y5/9SuLf4M+z2/rXSh7 +zQIaPIgwocKFDBs6fAgxosSJjehRHGhxB7z+ZBm/6StSrmMukec2piN4kuQDfyUBhjPZ0tpLlP9k +cnTZgN0dcDdhOtBZz2ZKmj95asRZkWVOo+uYDlW5FOk9oU2lLlBa1KoCrFGp5gu5DWpXoit9zmNF +lslHJxfbun0LN67cuXTr2r2LN6/evbvspj2oVcbfnoP7iR17uGK7xCl37iy81WxWxkm9xpM8GexR +ygi4ToZc1vNVzJVBJzDdmXRmKapHBz5tGVNsgSZEV3aMsRXq0Xx7+/4NPLjw4cSLGz+OPLmK3b5f +p3COinlN6QGo21bsCfp05tqrt3bNGfZm6ojDe+/e/fzs1eNqXz/wXjwM6PHTh17fdZT2+N7+BeMv +Wop1/ykHCnkEHohgggouyGCDDj4oCITRDQiYeYyYx598oti3wnfqkcfhPhRqeIJTMT02Im+a8fJc +fRamll6MKRqQ4WcGFjLfjKmFBYyHJb5Io4+s3QgekAHq6J5gcBEpYZNOPglllFJO2R+V2SFpZY5M +NvlijVXqZ+SWMHKHpXq45Yjjj0J+OV6XZfLnZZFijsRjnc+oGeI1K26WpntrRojmmbG0WOaRehmZ +ZaKKLspoo44+CmmkksyZZIJ54kkmoAX+2aGQHF5qJylAzQRknCIKuthrXsYJYpiFRkbfq/aBSo4g ++yEaJIqUBgXMW6YGCiGtGj25q6TGHov+bLLKLstss2ziOWhc0gn7YXif4morhpyWxtmqrz57Z7hD +flcjq1jC+S2sM8rI7rnuLucporNyWuypmy7mbK/57stvv/7+C3DAAvd1r4S/9gnSXAe3ieKG2MJn +Im21MvwJqKPeoqeWpbpp8Z8Z3thuqCJOuy0iGmf8o70UlfswvL6m22+9A89Mc80231yXzKLKiyvJ +OieMMp/AtjcsphZ+7LGP3oqJ9K3oxSvgpRdfNrTQRe+p67uoRlsxzEFSm9ycC+/7M85mn4122mqv +zfZXbSOWM89rUez2hE4j2bTS3zK9Zt5kvmcuk1NP5dzghFlLb8lf6+2i39q2KnXfks8fCzTCIx89 +ude56Vv51W9/Dnrooo9Oeummn4566g4UAAA7 +END_OF_GIF + + return $gif; + +} # end encoded_gif + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/twind.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/twind.pl new file mode 100755 index 00000000000..5b67fa1d60a --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/twind.pl @@ -0,0 +1,186 @@ +# twind.pl + +use Plot; +use subs qw/twind_create_plot twind_delete_plot twind_restore_bg/; +use vars qw/$TOP/; + +sub twind { + + # Create a top-level window with a text widget that demonstrates the + # use of embedded windows in Text widgets. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => '', + -title => 'Text Demonstration - Embedded Windows', + -iconname => 'twind', + ); + + # By default, when you create a Scrolled instance of a Perl/Tk widget + # the scrollbars are always displayed; that is, they are required. But + # you can have optional scrollbars as well, specified via the -scrollbars + # specifier. So, assume scrollbars can be postioned 'nsew' (north, south + # east or west), or 'se' for southeast, etcetera. You specify 'required' + # or 'optional' using an 'r' or 'o' character, respectively, preceeding + # the scrollbar position. So the following Scrolled widget has an + # optional scrollbar at the bottom of the text widget and a required + # scrollbar positioned to the right. + # + # Optional scrollbars are only displayed if they are required, so, the + # the southern scrollbar is displayed IFF -wrap => none. + + my $t = $TOP->Scrolled(qw/Text -setgrid true -width 70 -height 35 + -wrap word -highlightthickness 0 -borderwidth 0 -scrollbars osre + -font/ => $FONT)->pack; + + $t->tag(qw/configure center -justify center -spacing1 5m -spacing3 5m/); + $t->tag(qw/configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c + -spacing1 3m -spacing2 0 -spacing3 0/); + + my $t_on = $t->Button( + -text => 'Turn On', + -command => [$t => qw/configure -wrap none/], + -cursor => 'top_left_arrow', + ); + my $t_off = $t->Button( + -text => 'Turn Off', + -command => [$t => qw/configure -wrap word/], + -cursor => 'top_left_arrow', + ); + + my $t_click = $t->Button( + -text => 'Click Here', + -command => [\&twind_create_plot, $t], + -cursor => 'top_left_arrow', + ); + my $t_delete = $t->Button( + -text => 'Delete', + -command => [\&twind_delete_plot, $t], + -cursor => 'top_left_arrow', + ); + + $t->insert('end', "A text widget can contain other widgets embedded "); + $t->insert('end', "in it. These are called "); + $t->insert('end', "\"embedded windows\""); + $t->insert('end', ", and they can consist of arbitrary widgets. "); + $t->insert('end', "For example, here are two embedded button "); + $t->insert('end', "widgets. You can click on the first button to "); + $t->window('create', 'end', -window => $t_on); + $t->insert('end', " horizontal scrolling, which also turns off "); + $t->insert('end', "word wrapping. Or, you can click on the second "); + $t->insert('end', "button to\n"); + $t->window('create', 'end', -window => $t_off); + $t->insert('end', " horizontal scrolling and turn back on word "); + $t->insert('end', "wrapping.\n\n"); + + $t->insert('end', "Or, here is another example. If you "); + $t->window('create', 'end', -window => $t_click); + $t->insert('end', " a canvas displaying an x-y plot will appear "); + $t->insert('end', "right here."); + $t->mark('set', 'plot', 'insert'); + $t->mark('gravity', 'plot', 'left'); + $t->insert('end', " You can drag the data points around with the "); + $t->insert('end', "mouse, or you can click here to "); + $t->window('create', 'end', -window => $t_delete); + $t->insert('end', " the plot again.\n\n"); + + $t->insert('end', "You may also find it useful to put embedded windows"); + $t->insert('end', " in a text without any actual text. In this case "); + $t->insert('end', "the text widget acts like a geometry manager. For "); + $t->insert('end', "example, here is a collection of buttons laid out "); + $t->insert('end', "neatly into rows by the text widget. These buttons"); + $t->insert('end', " can be used to change the background color of the "); + $t->insert('end', "text widget (\"Default\" restores the color to "); + $t->insert('end', "its default). If you click on the button labeled "); + $t->insert('end', "\"Short\", it changes to a longer string so that "); + $t->insert('end', "you can see how the text widget automatically "); + $t->insert('end', "changes the layout. Click on the button again "); + $t->insert('end', "to restore the short string.\n"); + + my $t_default = $t->Button( + -text => 'Default', + -command => [\&twind_restore_bg, $t], + -cursor => 'top_left_arrow', + ); + $t->window('create', 'end', -window => $t_default, -padx => 3); + my $embToggle = 'Short'; + my $t_toggle = $t->Checkbutton( + -textvariable => \$embToggle, + -indicatoron => 0, + -variable => \$embToggle, + -onvalue => 'A much longer string', + -offvalue => 'Short', + -cursor => 'top_left_arrow', + ); + $t->window('create', 'end', -window => $t_toggle, + -padx => 3, -pady => 2); + my($i, $color) = (1, ''); + foreach $color (qw(AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4 + SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3 + LightBlue1 DarkSlateGray1 Aquamarine2 DarkSeaGreen2 + SeaGreen1 Yellow1 IndianRed1 IndianRed2 Tan1 Tan4)) { + my $col = $t->Button( + -text => "$color", + -cursor => 'top_left_arrow', + ); + $col->configure(-command => sub { + $t->configure(-background => $color); + }); + $t->window('create', 'end', -window => $col, + -padx => 3, -pady => 2); + $i++; + } + $t->tag('add', 'buttons', $t_default, 'end'); + +} # end twind + +sub twind_create_plot { + + # We are required to create a new Plot object everytime since embedded + # widgets are destroyed when their tag is deleted. (Too bad.) + + my($text) = @_; + + if (not Exists($twind::plot)) { + $twind::plot = $text->Plot( + -title_color => 'Brown', + -inactive_highlight => 'Skyblue2', + -active_highlight => 'red', + ); + + while ($text->get('plot') =~ / |\t|\n/) { + $text->delete('plot'); + } + $text->insert('plot', "\n"); + $text->window('create', 'plot', -window => $twind::plot); + $text->tag('add', 'center', 'plot'); + $text->insert('plot', "\n"); + } # ifend + +} # end twind_create_plot + +sub twind_delete_plot { + + my($text) = @_; + + if (Exists($twind::plot)) { + $text->delete($twind::plot); + while ($text->get('plot') =~ / |\t|\n/) { + $text->delete('plot'); + } + $text->insert('plot', ' '); + } + +} # end twind_delete_plot + +sub twind_restore_bg { + + my($text) = @_; + + $text->configure(-background => + ($text->Subwidget('text')->configure(-background))[3]); + +} # end twind_restore_bg + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/unicodeout.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/unicodeout.pl new file mode 100755 index 00000000000..b898810fd6d --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/unicodeout.pl @@ -0,0 +1,64 @@ +# unicodeout.pl + +use vars qw/$TOP/; +use subs qw/unicodeadd/; + +sub unicodeout { + + # This demonstration script shows how you can produce output (in label + # widgets) using many different alphabets. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'This is a sample of Perl/Tk\'s support for languages that use non-Western character sets. However, what you will actually seebelow depends largely on what character sets you have installed, and what you see for characters that are not present varies greatly between platforms as well. The strings are written in Perl Unicode characters using the \\x{XXXX} escape sequence so as to do so in a portable fashion.', + -title => 'Unicode Label Demonstration', + -iconname => 'unicodeout', + ); + + my $unicode_wait = $TOP->Label( + -text => 'Please wait while loading fonts...', + -font => 'Helvetica 12 italic', + )->pack; + $TOP->update; + + # Processing when some characters are missing might take a while, so make + # sure we're displaying something in the meantime. + + $TOP->Busy; + + unicodeadd $TOP, 'Arabic', + "\x{FE94}\x{FEF4}\x{FE91}\x{FEAE}\x{FECC}\x{FEDF}\x{FE8D}\x{FE94}\x{FEE4}\x{FEE0}\x{FEDC}\x{FEDF}\x{FE8D}"; + unicodeadd $TOP, "Trad. Chinese", "\x{4E2D}\x{570B}\x{7684}\x{6F22}\x{5B57}"; + unicodeadd $TOP, "Simpl. Chinese", "\x{6C49}\x{8BED}"; + unicodeadd $TOP, 'Greek', + "\x{0395}\x{03BB}\x{03BB}\x{03B7}\x{03BD}\x{03B9}\x{03BA}\x{03AE}\x{03B3}\x{03BB}\x{03CE}\x{03C3}\x{03C3}\x{03B1}"; + unicodeadd $TOP, 'Hebrew', + "\x{05DD}\x{05D9}\x{05DC}\x{05E9}\x{05D5}\x{05E8}\x{05D9}\x{05DC}\x{05D9}\x{05D0}\x{05E8}\x{05E9}\x{05D9}"; + unicodeadd $TOP, 'Japanese', + "\x{65E5}\x{672C}\x{8A9E}\x{306E}\x{3072}\x{3089}\x{304C}\x{306A}\x{6F22}\x{5B57}\x{3068}\x{30AB}\x{30BF}\x{30AB}\x{30CA}"; + unicodeadd $TOP, 'Korean', + "\x{B300}\x{D55C}\x{BBFC}\x{AD6D}\x{C758}\x{D55C}\x{AE00}"; + unicodeadd $TOP, 'Russian', + "\x{0420}\x{0443}\x{0441}\x{0441}\x{043A}\x{0438}\x{0439}\x{044F}\x{0437}\x{044B}\x{043A}"; + + # We're done processing, so change things back to normal running. + + $unicode_wait->destroy; + $TOP->Unbusy; + +} # end unicodeout + +sub unicodeadd { + + my ($w, $language, @args) = @_; + + my $sample = join('', @args); + my $l1 = $w->Label(-text => "$language: ", qw/-anchor nw -pady 0/); + my $l2 = $w->Label(-text => $sample, qw/-anchor nw -width 30 -pady 0/); + $l1->grid($l1, $l2, qw/-sticky ew -pady 0/); + $l1->gridConfigure(qw/-padx 1m/); + +} # end unicodeadd + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/virtevents1.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/virtevents1.pl new file mode 100755 index 00000000000..8e2e85106f8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/virtevents1.pl @@ -0,0 +1,59 @@ +use strict; + +sub virtevents1 { + + my( $demo ) = @_; + + my $mw = $MW->WidgetDemo( + -name => $demo, + -text => [ "This demonstration shows how you can use keysyms (keyboard symbols) to programmatically synthesize events that simulate a person typing on the keyboard. To learn about keyboard keysyms, run to previous demonstration, \"Show keyboard symbols\". + +A virtual event named <<pTkRules>> is defined that is activated by pressing the \"caps lock\" key (go ahead, press \"caps lock\"). A callback is bound to that virtual event - the callback synthesizes physicals events that \"type\" into the Entry widget displayed below. Pressing the \"Synthesize\" Button calls eventGenerate(), which synthesizes the virtual event <<pTkRules>> directly. + +Warning: it's easy to make this demonstration recurse indefinitely because synthesized physical events behave just like the real thing. So, it's possible for the <<pTkRules>> callback to eventGenerate() the keysym that activates the <<pTkRules>> virtual event, which invokes the <<pTkRules>> callback to eventGenerate() the keysym that activates the <<pTkRules>> virtual event, which ...", -wraplength => '6i' ], + -title => 'Simulate KeyPress events.', + -iconname => 'vevents1', + ); + + # Define a virtual event - <<pTkRules>> - that is activated when + # the physical event - pressing the "caps lock" key - occurs. + + $mw->eventAdd( qw/ <<pTkRules>> <Caps_Lock> / ); + + # Alphabetics are their own keysyms. The %keysyms hash maps other + # characters to their keysym string. To see the keysyms associated + # with keyboard characters run the previous widget demonstration. + + my %keysyms = (' ' => 'space', '/' => 'slash', '!' => 'exclam' ); + + # Create an Entry widget for a person or this program to type into. + # The Button explicitly generates the virtual event. + + my $e = $mw->Entry->pack; + my $b = $mw->Button( + -command => sub { $mw->eventGenerate( '<<pTkRules>>' ) }, + -text => 'Synthesize <<pTkRules>>', + )->pack; + + # Now bind the virtual event to a callback that "types" for us. + + $mw->bind( qw/ <<pTkRules>> / => sub { + + # This subroutine is invoked whenever the "caps lock" key is + # pressed or the virtual event <<pTkRules>> is programatically + # generated via eventGenerate. + + $e->focus; + $mw->update; + my $string_to_type = 'Perl/Tk rules!'; + + foreach ( split '', $string_to_type ) { + $_ = $keysyms{$_} if exists $keysyms{$_}; + $e->eventGenerate( '<KeyPress>', -keysym => $_ ); + $mw->idletasks; + $mw->after( 100 ); + + } # end sub type characters + } ); + +} # end virtevents1 diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/vscale.pl b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/vscale.pl new file mode 100755 index 00000000000..1f7d076e93d --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/vscale.pl @@ -0,0 +1,48 @@ +# vscale.pl + +use subs qw/vscale_height/; +use vars qw/$TOP/; + +sub vscale { + + # Create a top-level window that displays a vertical scale. + + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'An arrow and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow.', + -title => 'Vertical Scale Demonstration', + -iconname => 'vscale', + ); + + my $frame = $TOP->Frame(-borderwidth => 10)->pack; + + my $canvas = $frame->Canvas( + qw/-width 50 -height 50 -borderwidth 0 -highlightthickness 0/); + $canvas->createPolygon(qw/0 0 1 1 2 2 -fill SeaGreen3 -tags poly/); + $canvas->createLine(qw/0 0 1 1 2 2 0 0 -fill black -tags line/); + + my $scale = $frame->Scale(qw/-orient vertical -length 284 -from 0 + -to 250 -tickinterval 50 -command/ => [\&vscale_height, $canvas]); + $scale->set(75); + + $scale->pack(qw/-side left -anchor ne/); + $canvas->pack(qw/-side left -anchor nw -fill y/) + +} # end vscale + +sub vscale_height { + + my($w, $height) = @_; + + $height += 21; + my $y2 = $height - 30; + $y2 = 21 if $y2 < 21; + $w->coords('poly', 15, 20, 35, 20, 35, $y2, 45, $y2, 25, $height, 5, $y2, + 15, $y2, 15, 20); + $w->coords('line', 15, 20, 35, 20, 35, $y2, 45, $y2, 25, $height, 5, $y2, + 15, $y2, 15, 20); + +} # end vscale_height + +1; |