summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/demos/widtrib
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widtrib')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Gedi.pl429
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/TEMPLATE.pl92
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Tiler.pl15
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl315
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/cursor.pl65
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuzbin0 -> 26699 bytes
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl226
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/plop.pl381
8 files changed, 1523 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Gedi.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Gedi.pl
new file mode 100644
index 00000000000..ff847000e05
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Gedi.pl
@@ -0,0 +1,429 @@
+# Gedi master advanced text editor.
+
+use Tk::TextEdit;
+
+use vars qw/$TOP/;
+
+my $TOP;
+my $text_frame;
+my $counter_frame;
+my $textwindow;
+my $current_line_label;
+my $total_line_label;
+my $current_column_label;
+my $insert_overstrike_mode_label;
+my $about_pop_up_reference;
+my $menu;
+my $help_menu;
+
+sub about_pop_up
+{
+ my $name = ref($about_pop_up_reference);
+ if (defined($about_pop_up_reference))
+ {
+ $about_pop_up_reference->raise;
+ $about_pop_up_reference->focus;
+ }
+ else
+ {
+ my $pop = $TOP->Toplevel();
+ $pop->title("About");
+
+ $pop->Label(-text=>"Gedi (Gregs EDItor)")->pack();
+ $pop->Label(-text=>"Ver. 1.0")->pack();
+ $pop->Label(-text=>"Copyright 1999")->pack();
+ $pop->Label(-text=>"Greg London")->pack();
+ $pop->Label(-text=>"All Rights Reserved.")->pack();
+ $pop->Label(-text=>"This program is free software.")->pack();
+ $pop->Label(-text=>"You can redistribute it and/or")->pack();
+ $pop->Label(-text=>"modify it under the same terms")->pack();
+ $pop->Label(-text=>"as Perl itself.")->pack();
+ $pop->Label(-text=>"Special Thanks to")->pack();
+ $pop->Label(-text=>"Nick Ing-Simmons.")->pack();
+
+ my $button_ok = $pop->Button(-text=>'OK',
+ -command => sub {$pop->destroy();
+ $about_pop_up_reference = undef;
+ } )
+ ->pack();
+ $pop->resizable('no','no');
+ $about_pop_up_reference = $pop;
+ }
+}
+
+
+sub update_indicators
+{
+ my ($line,$column)= split(/\./,$textwindow->index('insert'));
+ $current_line_label->configure (-text=> "line: $line");
+ $current_column_label->configure (-text=> "column: $column");
+
+ my ($last_line,$last_col) = split(/\./,$textwindow->index('end'));
+ $total_line_label->configure (-text=> "total lines: $last_line");
+
+ my $mode = $textwindow->OverstrikeMode;
+ my $overstrke_insert='Insert Mode';
+ if ($mode)
+ {$overstrke_insert='Overstrike Mode';}
+ $insert_overstrike_mode_label->configure
+ (-text=> "$overstrke_insert");
+
+ my $filename = $textwindow->FileName;
+ $filename = 'NoName' unless(defined($filename));
+ my $edit_flag='';
+ if($textwindow->numberChanges)
+ {$edit_flag='edited';}
+ $TOP->configure(-title => "Gedi $edit_flag $filename");
+ $textwindow->idletasks;
+
+}
+
+
+
+
+
+
+sub Gedi {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Gedi master advanced text editor ',
+ -geometry_manager => 'grid',
+ -title => 'GEDI Text Editor',
+ -iconname => 'GEDI',
+ );
+
+$TOP->withdraw;
+
+$text_frame = $TOP->Frame->pack
+ (-anchor=>'nw', -expand=>'yes', -fill => 'both'); # autosizing
+$counter_frame = $TOP->Frame->pack(-anchor=>'nw');
+
+$textwindow = $text_frame->Scrolled(
+ 'TextEdit',
+ exportselection => 'true', # 'sel' tag is associated with selections
+ # initial height, if it isnt 1, then autosizing fails
+ # once window shrinks below height
+ # and the line counters go off the screen.
+ # seems to be a problem with the Tk::pack command;
+# height => 40,
+ -background => 'white',
+ -wrap=> 'none',
+ -setgrid => 'true', # use this for autosizing
+ -scrollbars =>'se')
+ -> pack(-expand => 'yes' , -fill => 'both'); # autosizing
+
+$TOP->protocol('WM_DELETE_WINDOW'=>
+ sub{$textwindow->ConfirmExit;}
+ );
+
+$SIG{INT} = sub {$textwindow->ConfirmExit;};
+
+$current_line_label = $counter_frame
+ -> Label(-text=>'line: 1')
+ -> grid(-row=>1,-column=>1, -sticky=>'nw' );
+
+$total_line_label = $counter_frame
+ -> Label(-text=>'total lines: 1')
+ -> grid(-row=>2,-column=>1, -sticky=>'nw' );
+
+$current_column_label = $counter_frame
+ -> Label(-text=>'column: 0')
+ -> grid(-row=>3,-column=>1, -sticky=>'nw' );
+
+$insert_overstrike_mode_label = $counter_frame
+ -> Label(-text=>' ')
+ -> grid(-row=>5,-column=>1, -sticky=>'nw' );
+
+$textwindow->SetGUICallbacks (
+ [
+ \&update_indicators,
+ sub{$textwindow->HighlightAllPairsBracketingCursor}
+ ]
+);
+
+$menu = $textwindow->menu;
+
+$TOP->configure(-menu => $menu);
+
+$help_menu = $menu->cascade(-label=>'~Help', -tearoff => 0, -menuitems => [
+ [Command => 'A~bout', -command => \&about_pop_up]
+ ]);
+
+
+#$TOP->minsize(30,1);
+#$TOP->geometry("80x24");
+
+while(<DATA>)
+ {$textwindow->insert('insert',$_);}
+$textwindow->ResetUndo;
+
+$textwindow->CallNextGUICallback;
+
+# adjust height
+$TOP->update;
+my $menuheight = ($TOP->wrapper)[1];
+my $TOPheight = 30 + $TOP->reqheight + $menuheight;
+if ($TOP->screenheight < $TOPheight) {
+ $textwindow->GeometryRequest($textwindow->reqwidth, $textwindow->reqheight - ($TOPheight - $TOP->screenheight));
+}
+$TOP->deiconify;
+
+}
+
+
+__DATA__
+
+Tk800.015 contains many modifications to the
+text based modules, as well as new text modules
+and an application that uses them all.
+Text.pm, TextUndo.pm, TextEdit.pm, and gedi
+have all been updated since the release prior
+to Tk800.015.
+
+This demo contains a rundown of all the features
+of the text modules, and
+
+What is available in the text modules?
+================================================
+
+Text.pm
+========
+
+Text.pm is the base text editing module.
+Beyond the core functionality of typing text,
+Text.pm has built in menu support for basic
+editing features such as Find/Replace text,
+Copy/Cut/Paste, Goto Line Number, and What
+Line Number queries.
+
+These functions are available simply by right
+clicking the mouse over the text area. Doing
+so will cause a pop-up menu to appear which will
+contain cascading menus to give access to all of
+these new functions.
+
+Many of these functions will create their own
+pop-up windows. Find/Replace will create a pop-up
+window which contains an entry for text to
+find, an entry for replace text, a number of
+radio buttons to control options such as
+case sensitivity, and several command buttons to
+perform functions such as Find, Find All,
+Replace, Replace All.
+
+All of these features have corresponding methods
+built into the Text widget. This allows the basic
+functions to be built into the widget, and also
+allows added features to be built on the lower
+level methods as needed. No one should have to
+reinvent the wheel when it comes to text editing
+features.
+
+Insert and Overstrike modes are also supported
+in the Text.pm module. Pressing the <Insert>
+key will toggle modes back and forth.
+
+Column based copy/cut/paste features are also
+available in the Text.pm module. They are bound
+to the following keys:
+
+<F1> clipboardColumnCopy
+<F2> clipboardColumnCut
+<F3> clipboardColumnPaste
+
+Currently, column based operations are beta versions.
+They compensate for tabs, but they will not behave
+properly unless the text is all the same font, and
+is the same width per character.
+
+Hopefully some future version of Text.pm will correct
+for this deficiency.
+
+Column paste should work with overstrike mode.
+
+
+TextUndo.pm
+=============
+
+TextUndo.pm is the second level module, being
+derived from the Text.pm module. As it's name
+implies, TextUndo supports "UNDO" capability.
+It now also supports "REDO" capability.
+
+Undo/redo works on user typed commands and
+also programmatically, so that any application
+that causes text to be inserted or deleted
+can be undone/redone, whether it was directly
+typed by the user or indirectly through another
+method.
+
+The undo/redo functions support tags, so that
+if you delete text with tags, undo will re-insert
+the text and re-tag it as well. This will eventually
+allow the text modules to support more sophisticated
+word processing type features. Such functionality
+should be available in a future release of the
+text modules.
+
+The TextUndo.pm module also has several added
+features to support file based operations.
+File based methods include ->Save, ->Load, and
+->Include. All methods take a filename as a
+parameter. These methods will create a progress
+widget to indicate the progress of the operation.
+
+The other feature of the TextUndo.pm module
+is the ConfirmDiscard method. This method checks to
+see if the text has been modified since it was
+last saved. If it has been modified, and the
+it will create a pop-up menu asking the user
+if they want to save the text to a file before
+exiting. This method can easily be tied into
+the exit routines, and signal handlers, to provide
+a consistent "save before exit?" feel.
+
+TextEdit.pm
+=============
+
+The TextEdit.pm is a new module in prototype version
+which adds further features to the text modules.
+TextEdit is based off of the TextUndo module,
+and so has all of the features of TextUndo and
+Text.
+
+Features of the TextEdit.pm module include
+parenthesis matching. The module looks at the
+current cursor position and then tries to find
+the parenthesis that bracket the cursor.
+Character pairs that are searched for are:
+() {} [] "" ''
+
+It also checks the position of the pairs to
+try to highlight bad positions. The module
+assumes that if the pairs are not on the same
+line or not on the same column, then there
+might be a missing parenthesis somewhere.
+Characters that appear to not align are
+highlighted in red.
+
+(quotations must start and end on the same line)
+
+
+PARENTHISIS MATCHING DEMO:
+move the cursor to the x between the quotes
+on the line below:
+
+
+{
+ ( )
+ ( { }
+ [
+ ' ">> x <<" '
+ [] ]
+ )
+
+}
+
+PARENTHESIS MISMATCHING DEMO:
+move the cursor to the x between the quotes
+on the line below:
+
+
+{
+ ( )
+ ( <<RED possible error { }
+ [
+ ' ">> x <<" '
+ [] ]
+ ) <<RED possible error
+
+}
+
+
+
+Another feature of the TextEdit module is support
+for application level indicators which reflect
+the status of certain internals. The line and
+column position of the cursor, the total length
+of the file, whether the widget is in insert or
+overstrike mode. Anytime anything occurs that could
+affect these values, a user supplied callback
+is invoked. This callback is supplied by the
+application so that the application can update
+whatever indicators it uses, however it implements
+them.
+
+One other feature of the TextEdit.pm module is
+block level text indention and block level text
+commenting. If a block of text is selected,
+that text can be indented or unindented wiht
+a single keystroke. It can also be commented
+out or uncommented as well. The keystroke bindings
+that support this are:
+
+<F5> IndentSelectedLines
+<F6> UnindentSelectedLines
+
+<F7> CommentSelectedLines
+<F8> UncommentSelectedLines
+
+These bindings only operate on the currently
+selected text. The indent string and the comment
+string can be programmed to be anything, but
+defaults to "\t" (tab) for indent and "#" for
+comments.
+
+(currently the widget hash is used to store these values.
+$w->{'INDENT_STRING'} and $w->{'LINE_COMMENT_STRING'}
+At some point in the future, this will be changed to
+use configure options to set these values.
+any application that changes these values should do
+so in such a way that when the TextEdit module changes,
+the application can be easily changed to handle this)
+
+
+
+gedi application
+=====================
+gedi is short for Greg's EDItor.
+The "g" is soft, pronounced like a "j".
+
+The gedi application uses all of the features of
+the text modules, Text, TextUndo, and TextEdit.
+It supplies TextEdit with a callback to update
+the indicator displays. This information includes
+the current cursor position, insert/overstrike
+mode, length of the file, filename, and whether
+the file has been edited or not.
+
+The bottom of this display contains
+line number
+column number
+total lines
+insert/overstrike mode.
+
+The title bar contains
+filename
+and if the file has been edited, the word "edited".
+
+Where gedi is installed depends on your system,
+but it is part of the tarkit for Tk800.015 and above.
+
+gedi was created to be put a perl editor in with the
+perl tar kit.
+
+NOTE: THIS IS NOT THE ACTUAL GEDI APPLICATION, BUT
+A DEMO SET UP TO BE SIMILAR IN NATURE TO THE GEDI
+APPLICATION. THE ACTUAL GEDI APPLICATION IS PART OF
+THE TK800.015 TARKIT. WHERE IT IS LOCATED ON YOUR
+SYSTEM WILL VARY DEPENDING ON YOUR SYSTEM. ONCE
+YOU LOCATE THE GEDI APPLICATION, PUT IT IN YOUR
+EXECUTABLE PATH, AND YOU WILL BE ABLE TO USE IT AS
+A TEXT EDITOR.
+
+
+
+
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/TEMPLATE.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/TEMPLATE.pl
new file mode 100644
index 00000000000..f0415ea9cae
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/TEMPLATE.pl
@@ -0,0 +1,92 @@
+# Learn how to write your own widget demonstration.
+
+use vars qw/$TOP/;
+
+sub TEMPLATE {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => 'Learn how to write a widget demonstration!',
+ -geometry_manager => 'grid',
+ -title => 'WidgetDemo Example',
+ -iconname => 'WidgetDemo',
+ );
+ $TOP->Label(-text => 'Click "See Code".')->grid;
+}
+__END__
+
+The template code above specifies how user contributed widget demonstrations
+can be written.
+
+widget looks in the directory specified on the command line to load user
+contributed demonstrations. If no directory name is specified when widget is
+invoked and the environment variable WIDTRIB is defined then demonstrations
+are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget
+defaults to the released user contributed directory.
+
+The first line of the file is the DDD (Demonstration Description Data), which
+briefly describes the purpose of the demonstration. The widget program reads
+this line and uses it when building its interface.
+
+Demonstrations must have a unique subroutine which is the same as the filename
+with .pl stripped off. When widget calls your subroutine it's passed one
+argument, the demonstration name. So file TEMPLATE.pl contains subroutine
+TEMPLATE(). But a demo can actually be an entire program - read on!
+
+For consistency your demonstration should use the WidgetDemo widget. This is
+a toplevel widget with three frames. The top frame contains descriptive
+demonstration text. The bottom frame contains the "Dismiss" and "See Code"
+buttons. The middle frame is the demonstration container, which can be
+managed by either the pack or grid geometry manager.
+
+Since your subroutine can "see" all of widget's global variables, you
+use $MW (the main window reference) to create the WidgetDemo toplevel; be sure
+to pass at least the -name and -text parameters. -geometry_manager defaults
+to "pack". The call to WidgetDemo() returns a reference to the containing
+frame for your demonstration, so treat it as if it were the MainWindow, the
+top-most window of your widget hierarchy.
+
+Alternatively the .pl file may contain typical Perl/Tk code of the form:
+
+ # Demonstration Description Data
+
+ use Tk;
+ my $top = MainWindow->new;
+ $top->Label(-text => 'Whatever');
+ MainLoop;
+ __END__
+
+widget has re-defined normal MainWindow to actually create a WidgetDemo
+on your code's behalf. MainLoop is optional in a demo (it will immediately
+return as MainLoop is already active).
+
+Other consideration:
+
+ . widget global variables are all uppercase, like $MW - be careful not
+ to stomp on them!
+
+ . Demo files should really be run in private packages to avoid those
+ problems.
+
+ . Don't subvert the inheritance mechanism by calling Tk::MainWindow
+ in your demo code.
+
+ . The description should really be extracted from POD documentation
+ in the .pl file rather than a magic comment.
+
+ . If your demonstration has a Quit button change it to ring the bell
+ and use the builtin Dismiss instead. In particular destroying a
+ MainWindow is acceptable, but exit will shut down widget itself!
+
+ . Be sure $TOP is declared in a "use vars" statement and not as a
+ lexical my() in the subroutine (see below).
+
+ . If you're wrapping an existing main program in a subroutine be very
+ alert for closure bugs. Lexicals inside a subroutine become closed
+ so you may run into initialization problems on the second and
+ subsequent invokations of the demonstration. The npuz and plop
+ demonstrations show how to work around this. Essentially, remove
+ all "global" my() variables and place them within a "use vars".
+ This practice is prone to subtle bugs and is not recommended!
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Tiler.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Tiler.pl
new file mode 100644
index 00000000000..c9a44b8c0b1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Tiler.pl
@@ -0,0 +1,15 @@
+# Tiler, arrange widgets in rows.
+
+use strict;
+use Tk;
+use Tk::Tiler;
+
+my $mw = MainWindow->new();
+my $tiler = $mw->Scrolled('Tiler');
+my $num = $tiler->cget('-rows') * $tiler->cget('-columns');
+$mw->Label(-text => "Tiler with $num widgets")->pack;
+foreach (1 .. $num) {
+ $tiler->Manage( $tiler->Label(-text => "**$_**") );
+}
+$tiler->pack(qw/-expand yes -fill both/);
+MainLoop;
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl
new file mode 100644
index 00000000000..2152465c462
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl
@@ -0,0 +1,315 @@
+# All widgets at a glance.
+# -*- perl -*-
+
+#
+# $Id: $
+# Author: Slaven Rezic
+#
+# Copyright (C) 2007 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: slaven@rezic.de
+# WWW: http://www.rezic.de/eserte/
+#
+
+use strict;
+use Tk::Pane;
+
+use vars qw/$TOP $MW $DEMO_FILE/;
+
+sub all {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => <<"EOF",
+All Tk widgets at a glance in one Toplevel.
+
+The left column contains the class name, the middle column a sample representation of this widget, and the right column a button to the widget's Pod (requires Tk::Pod from CPAN).
+
+There are two sections: core Tk modules which come with stock Tk $Tk::VERSION and a sample of non-standard Tk modules from CPAN. The non-standard modules are only displayed if installed, otherwise they are skipped.
+EOF
+ -geometry_manager => 'pack',
+ -title => 'All widgets',
+ -iconname => 'All widgets',
+ );
+
+ my($px_w, $px_h) = (400, 200);
+ my($txt_w, $txt_h) = (40, 6);
+ my @px_geom = (-width => $px_w, -height => $px_h);
+ my @txt_geom = (-height => $txt_h, -width => $txt_w);
+ my $insert_txt = sub {
+ my $w = shift;
+ if ($w->can("Subwidget") && $w->Subwidget("scrolled")) {
+ $w = $w->Subwidget("scrolled");
+ }
+ $w->insert("end", "This is some sample text for the widget class " . $w->Class);
+ };
+ my $insert_lb = sub {
+ shift->insert("end", sort grep { !m{^/} } keys %INC);
+ };
+
+ my $f = $TOP->Scrolled('Pane',
+ qw(-width 900 -height 500), # XXX check for screensize!
+ -gridded => 'xy',
+ -scrollbars => 'osoe',
+ -sticky => 'news',
+ )->pack(qw(-expand 1 -fill both));
+ $f = $f->Subwidget("scrolled");
+ my @w_def = (
+ {separator => 'Core Tk modules'},
+
+ 'Adjuster',
+ # XXX 'Balloon',
+ {class => 'BrowseEntry', action => $insert_lb},
+ {class => 'Button', w_args => [-text => 'This is a button']},
+ {class => 'Canvas', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..50) {
+ $w->createLine(rand($px_w),rand($px_h),
+ rand($px_w),rand($px_h),
+ -fill => $colors[rand @colors],
+ -width => rand(4)+1,
+ );
+ }
+ },
+ },
+ {class => 'Checkbutton', w_args => [-text => 'This is a checkbutton']},
+ {class => 'ColorEditor', dialog => 1},
+ {class => 'Dialog', dialog => 1},
+ {class => 'DialogBox', dialog => 1},
+ {class => 'DirTree', scrolled => 'oe'},
+ {class => 'Dirlist', scrolled => 'oe'},
+ {class => 'Entry', w_args => [-width => 20], action => $insert_txt},
+ {class => 'FBox', dialog => 1},
+ {class => 'FileDialog', dialog => 1},
+ {class => 'FileSelect', dialog => 1},
+ {class => 'Frame', w_args => [@px_geom, -bg => 'red']},
+ {class => 'Label', w_args => [-text => 'This is a label']},
+ {class => 'Labelframe', w_args => [@px_geom, -bg => 'red', -text => 'Title of frame']},
+ {class => 'Listbox', action => $insert_lb, scrolled => 'oe'},
+ # XXX Menubar?
+ {class => 'Menubutton', w_args => [-text => 'Menu button']},#XXX menuitems
+ {class => 'Message', w_args => [-text => 'This is a message widget']},
+ {class => 'MsgBox', dialog => 1},
+ {class => 'NoteBook', action => sub {
+ my $w = shift;
+ for (1..5) {
+ my $p = $w->add("page$_", -label => "Page $_");
+ $p->Label(-text => "A label in the page $_")->pack;
+ }
+ },
+ },
+ # XXX Pane
+ {class => 'Radiobutton', w_args => [-text => 'This is a radiobutton']},
+ {class => 'ROText', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ {class => 'Scale', w_args => [-orient => 'horiz', -from => 0, -showvalue => 1, -to => 100]},
+ {class => 'Scrollbar', w_args => [-orient => 'horiz']},
+ {class => 'Spinbox', w_args => [-from => 0, -to => 100]},
+ {class => 'Text', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ # disabled because of warning loop, line 189 ... {class => 'TextEdit', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ {class => 'TextList', w_args => [@txt_geom], action => $insert_lb, scrolled => 'oe'},
+ {class => 'TextUndo', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ # XXX Toplevel
+ qw(FloatEntry HList IconList InputO
+ LabEntry LabFrame LabRadio NBFrame Optionmenu
+ Panedwindow ProgressBar TList Table
+ Tiler TixGrid Tree
+ ),
+
+ {separator => 'Installed non-core Tk modules'},
+
+ qw(Date DateEntry NumEntry NumEntryPlain
+ PathEntry
+ ),
+ {class => 'FireButton', action => sub {
+ my $w = shift;
+ my $text = 'This is a firebutton 0';
+ $w->configure(-textvariable => \$text,
+ -command => sub {
+ $text =~ s{(\d+)}{$1+1}e;
+ },
+ );
+ },
+ },
+ {class => 'TFrame', w_args => [@px_geom, -bg => 'red',
+ -label => [ -text => 'Title' ],
+ -borderwidth => 2,
+ -relief => 'groove',
+ ],
+ },
+ {class => 'ToolBar', w_args => [qw/-movable 1 -side top
+ -indicatorcolor blue/],
+ action => sub {
+ my $tb = shift;
+ $tb->ToolButton (-text => 'Button',
+ -tip => 'tool tip',
+ -command => sub { print "hi\n" });
+ $tb->ToolLabel (-text => 'A Label');
+ $tb->Label (-text => 'Another Label');
+ $tb->ToolLabEntry(-label => 'A LabEntry',
+ -labelPack => [-side => "left",
+ -anchor => "w"]);
+ },
+ },
+ {class => 'HistEntry', action => sub {
+ my $w = shift;
+ $w->bind("<Return>" => sub {
+ # do something with value, and then:
+ $w->historyAdd;
+ $w->delete('0', 'end');
+ });
+ },
+ },
+ {class => 'MListbox', w_args => [-columns=>[[-text=>'Heading1',
+ -sortable=>0],
+ [-text=>'Heading2']]],
+ action => sub {
+ my $w = shift;
+ $w->insert("end", [qw(Cell11 Cell12)], [qw(Cell21 Cell22)]);
+ },
+ },
+ {class => 'Cloth', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..50) {
+ $w->Line(-coords => [rand($px_w),rand($px_h),
+ rand($px_w),rand($px_h)],
+ -fill => $colors[rand @colors],
+ -width => rand(4)+1,
+ );
+ }
+ },
+ },
+ {class => 'DirSelect', dialog => 1},
+ {class => 'ExecuteCommand', w_args => [@txt_geom]},
+ {class => 'FontDialog', dialog => 1},
+ {class => 'JBrowseEntry', action => $insert_lb},
+ {class => 'JFileDialog', dialog => 1},
+ {class => 'More', w_args => [@txt_geom], action => sub {
+ shift->Load($DEMO_FILE),
+ }, scrolled => 'oe'},
+ {class => 'ObjEditor', w_args => [@txt_geom, -caller => { dummy => 'object'}]},
+ {class => 'ObjScanner', w_args => [@txt_geom, -caller => $TOP]},
+ {class => 'PodText', require => 'Tk::Pod::Text',
+ w_args => [@txt_geom, -file => 'Tk']},
+ {class => 'XMLViewer', w_args => [@txt_geom], action => sub {
+ shift->insertXML(-text => "<?xml version='1.0' ?><a><bla /><foo>bar</foo></a>");
+ }, scrolled => 'oe'},
+ {class => 'Zinc', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..20) {
+ $w->add('curve', 1, [map { (rand($px_w),rand($px_h)) } (1..5)],
+ -relief => 'roundgroove',
+ -filled => 1,
+ -fillcolor => $colors[rand @colors],
+ );
+ }
+ },
+ },
+ );
+ $f->grid('columnconfigure', $_, -pad => 3, -weight => 1) for (0 .. 1);
+ $f->grid('rowconfigure', $_, -pad => 3, -weight => 1) for (0 .. $#w_def);
+ my $row = -1;
+ for my $w_def (@w_def) {
+ my($separator, $text, $class, @w_args, $action, $scrolled, $dialog, $dialog_action);
+ if (UNIVERSAL::isa($w_def, "HASH")) {
+ $separator = $w_def->{separator};
+ if (!$separator) {
+ $class = $w_def->{class};
+ $text = $w_def->{text} || $class;
+ @w_args = @{ $w_def->{w_args} || [] };
+ $action = $w_def->{action};
+ $scrolled = $w_def->{scrolled};
+ $dialog = $w_def->{dialog};
+ $dialog_action = $w_def->{dialog_action};
+ if ($dialog && !$dialog_action) {
+ $dialog_action = sub { shift->Show };
+ }
+ if ($w_def->{require}) {
+ eval 'require ' . $w_def->{require};
+ if ($@) {
+ warn $@;
+ next;
+ }
+ }
+ }
+ } else {
+ ($text, $class) = ($w_def, $w_def);
+ }
+
+ $row++;
+
+ if ($separator) {
+ $f->Label(-text => $separator,
+ -font => 'Helvetica 18',
+ -pady => 5,
+ )->grid(-row => $row,
+ -column => 0,
+ -columnspan => 3,
+ );
+ next;
+ }
+
+ my $bgcolor = $row%2==0 ? '#c0c0c0' : '#a0a0a0';
+ my $ff = $f->Frame(-background => $bgcolor,
+ )->grid(-row => $row,
+ -column => 1,
+ -sticky => 'news',
+ );
+ my $cw = eval {
+ if ($dialog) {
+ $ff->$class(@w_args)->destroy; # just load it...
+ $ff->Button(-text => 'Open ' . $class,
+ -command => sub {
+ # There are some buggy dialogs which display
+ # already without calling a Show method (e.g. Tk::FBox),
+ # so create here
+ my $d = $ff->$class(@w_args);
+ $dialog_action->($d) if $dialog_action;
+ })->pack;
+ } else {
+ if ($scrolled) {
+ $ff->Scrolled($class, @w_args, -scrollbars => $scrolled)->pack;
+ } else {
+ $ff->$class(@w_args)->pack;
+ }
+ }
+ };
+ if ($@ || !$cw) {
+ warn $@;
+ $row--;
+ $ff->destroy;
+ next;
+ }
+
+ $action->($cw) if $action && !$dialog;
+
+ $f->Label(-text => $text,
+ -background => $bgcolor,
+ -anchor => 'w',
+ )->grid(-row => $row,
+ -column => 0,
+ -sticky => "news",
+ );
+
+ $f->Button(-text => 'Pod',
+ -background => $bgcolor,
+ -command => sub {
+ require Tk::Pod;
+ $TOP->Pod(-file => 'Tk::' . $class);
+ },
+ )->grid(-row => $row,
+ -column => 2,
+ -sticky => 'news',
+ );
+ }
+ # $TOP->WidgetDump;
+}
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/cursor.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/cursor.pl
new file mode 100644
index 00000000000..645f1433d54
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/cursor.pl
@@ -0,0 +1,65 @@
+# Predefined cursors.
+# -*- perl -*-
+
+#
+# $Id: $
+# Author: Slaven Rezic
+#
+# Copyright (C) 2006,2008 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: slaven@rezic.de
+# WWW: http://www.rezic.de/eserte/
+#
+
+use vars qw/$TOP/;
+
+sub cursor {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => <<'EOF',
+This window displays the names of Tk's built-in
+resp. predefined X11 cursors. Click or move on
+the names to see the cursor shape.
+EOF
+ -geometry_manager => 'grid',
+ -title => 'Predefined cursors',
+ -iconname => 'Predefined cursors',
+ );
+
+ my $fh;
+ TRY_CURSORFONTH: {
+ for my $cursorfonth (Tk->findINC("X11/cursorfont.h"),
+ "/usr/X11R6/include/X11/cursorfont.h",
+ "/usr/include/X11/cursorfont.h",
+ ) {
+ last TRY_CURSORFONTH if (open $fh, $cursorfonth);
+ }
+ $TOP->Label(-text => "Sorry. I can't find X11/cursorfont.h on this system.")->grid;
+ return;
+ }
+
+ while(<$fh>) {
+ chomp;
+ if (/XC_(\S+)/) {
+ my $cursorname = $1;
+ next if $cursorname eq 'num_glyphs';
+ push @cursors, $cursorname;
+ }
+ }
+
+ $lb = $TOP->Scrolled("Listbox", -scrollbars => "ose", -selectmode => "browse")->grid(-sticky => "ns");
+ $lb->insert("end", @cursors);
+ $lb->bind("<Motion>", sub {
+ my($inx) = $lb->nearest($lb->Subwidget("scrolled")->XEvent->y);
+ $lb->configure(-cursor => $cursors[$inx]);
+ });
+ $lb->bind("<<ListboxSelect>>", sub {
+ my($inx) = $lb->curselection;
+ $lb->configure(-cursor => $cursors[$inx]);
+ });
+}
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz
new file mode 100644
index 00000000000..c5c8318d145
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz
Binary files differ
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl
new file mode 100644
index 00000000000..3a6ba17f937
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl
@@ -0,0 +1,226 @@
+# A N-puzzle implemented via the Grid geometry manager.
+#
+# This program is described in the Perl/Tk column from Volume 1, Issue 4 of
+# The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk
+# distribution with permission. It has been modified slightly to conform
+# to the widget demo standard.
+
+#!/usr/local/bin/perl -w
+#
+# puz - demonstrate the Grid geometry manager by implementing an n-puzzle.
+#
+# Stephen O. Lidie, Lehigh University Computing Center, lusol@Lehigh.EDU
+# 96/08/11.
+#
+# Copyright (C) 1996 - 1998 Stephen O. Lidie. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself.
+
+require 5.002;
+use Tk;
+use Tk::Dialog;
+use strict;
+use subs qw(beep create_puz create_ui puz_fini move_piece new_puz randomly xy);
+
+my $CAMEL; # Perl/Tk Xcamel.gif Photo image
+my $CAMEL_HEIGHT; # Xcamel height
+my $CAMEL_WIDTH; # Xcamel width
+my (@LEVELS) = (9, 16, 36, 64); # possible puzzle piece counts
+my $MW = MainWindow->new; # program's main window
+my @ORDER; # random puzzle piece ordinals
+my $PIECES = $LEVELS[1]; # total puzzle piece count
+my $OLD_PIECES = -1; # previous puzzle piece count
+my $PF; # puzzle Frame
+my @PUZ; # puzzle piece information
+my $SIDE; # pieces per side of puzzle
+my $SPACE; # shortcut to puzzle space piece
+my $SPACE_IMAGE; # space piece image
+
+create_ui;
+create_puz;
+
+sub beep {$MW->bell}
+
+sub create_puz {
+
+ return if $PIECES == $OLD_PIECES;
+
+ # Create all the puzzle pieces - buttons with images - and arrange them
+ # in a rectangular grid. @PUZ is a list of button widget references which
+ # represent the puzzle pieces.
+ #
+ # The actual ordering is controlled by @ORDER, a list of list of two:
+ #
+ # $ORDER[$i]->[0] = puzzle piece ordinal
+ # $ORDER[$i]->[1] = random number used to shuffle the puzzle ordinals
+ #
+ # If the puzzle frame $PF exists, we've been here before, which means that
+ # all images and widgets associated with the previous puzzle need
+ # destroying, plugging a potential memory leak. It's important to note
+ # that an image must be explicity deleted - it doesn't magically go away
+ # if a widget, which just happens to use it, is destroyed. So, loop
+ # through all the puzzle pieces and delete their images, then destroy the
+ # puzzle's master frame $PF, destroying all child widgets. Now, this
+ # scheme isn't particulary efficient, but it is simple; ideally, we'd like
+ # to create these images only once and reuse them as required.
+
+ if (Exists $PF) {
+ my $image;
+ foreach (@PUZ) {
+ $image = $_->cget(-image);
+ $image = $SPACE_IMAGE if not defined $image;
+ $image->delete;
+ }
+ $PF->destroy;
+ }
+
+ $PF = $MW->Frame->grid; # create the puzzle frame grid master
+ $OLD_PIECES = $PIECES;
+ $#PUZ = $#ORDER = $PIECES - 1;
+ $SIDE = sqrt $PIECES;
+
+ my($i, $o, $c, $r, $w, $h, $x, $y, $but, $gif);
+
+ foreach (0..$#ORDER) {$ORDER[$_] = [$_, undef]}
+
+ for($i = 0; $i <= $#PUZ; $i++) {
+ $o = $ORDER[$i]->[0];
+ ($c, $r) = xy $o; # puzzle ordinal to column/row
+ $w = $CAMEL_WIDTH / $SIDE;
+ $h = $CAMEL_HEIGHT / $SIDE;
+ $x = $c * $w; # x/column pixel offset
+ $y = $r * $h; # y/row pixel offset
+ $gif = $PF->Photo; # new, empty, GIF image
+ $gif->copy($CAMEL, -from => $x, $y, $x+$w, $y+$h);
+ $but = $PF->Button(-image => $gif,
+ -relief => 'flat',
+ -borderwidth => 0,
+ -command => \&beep,
+ -highlightthickness => 0,
+ );
+ $PUZ[$o] = $but;
+ ($c, $r) = xy $i;
+ $but->grid(-column => $c, -row => $r, -sticky => 'nsew');
+ if ($o == 0) {
+ $SPACE_IMAGE = $gif;
+ $SPACE = $but;
+ }
+ } # forend all puzzle pieces
+
+} # end create_puz
+
+sub create_ui {
+
+ # Create a color Photo image of the Xcamel puzzle.
+
+ $CAMEL = $MW->Photo(-file => "$WIDTRIB/lib/npuz/Xcamel.npuz");
+ $CAMEL_WIDTH = $CAMEL->image('width');
+ $CAMEL_HEIGHT = $CAMEL->image('height');
+
+ # Create the menubar.
+
+ my $mf = $MW->Frame(-bg => 'blue')->grid(-sticky => 'ew');
+ $mf->gridColumnconfigure(1, -weight => 1);
+
+ my $mbf = $mf->Menubutton(-text => 'File', -relief => 'raised');
+ $mbf->command(-label => 'New Puzzle', -command => \&new_puz);
+ $mbf->separator;
+ $mbf->command(-label => 'Quit', -command => [$MW => 'bell']);
+
+ my $mbp = $mf->Menubutton(-text => 'Prefs', -relief => 'raised');
+ my $pieces = 'Pieces';
+ $mbp->cascade(-label => $pieces);
+ my $mbpm = $mbp->cget(-menu);
+ my $mbpmp = $mbpm->Menu;
+ $mbp->entryconfigure($pieces, -menu => $mbpmp);
+ foreach (@LEVELS) {
+ $mbpmp->radiobutton(-label => $_,
+ -variable => \$PIECES,
+ -value => $_,
+ -command => \&create_puz,
+ );
+ }
+
+ my $mbq = $mf->Menubutton(-text => 'Help', -relief => 'raised');
+ my $about = $MW->Dialog(-text => <<"END"
+npuz Version 1.0\n
+Select \"File/New Puzzle\", then click around the red \"space\" to rearrange the pieces and solve the puzzle!\n\nThis program is described in the Perl/Tk column from Volume 1, Issue 4 of The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk distribution with permission.
+END
+ );
+ $about->configure(-wraplength => '6i');
+ $mbq->command(-label => 'About', -command => [$about => 'Show']);
+
+ $mbf->grid(-row => 0, -column => 0, -sticky => 'w');
+ $mbp->grid(-row => 0, -column => 1, -sticky => 'w');
+ $mbq->grid(-row => 0, -column => 2, -sticky => 'e');
+
+} # end create_ui
+
+sub puz_fini {
+
+ # Return true iff all puzzle pieces are in order.
+
+ my($i, $c, $r, %info);
+ for($i = 0; $i <= $#PUZ; $i++) {
+ ($c, $r) = xy $i;
+ %info = $PUZ[$i]->gridInfo;
+ return 0 if $c != $info{-column} or $r != $info{-row};
+ }
+ return 1;
+
+} # end puz_fini
+
+sub move_piece {
+
+ my($piece) = @_;
+
+ my(%info, $c, $r, $sc, $sr);
+ %info = $piece->gridInfo; ($c, $r) = @info{-column,-row};
+ %info = $SPACE->gridInfo; ($sc, $sr) = @info{-column,-row};
+ if ( ($sr == $r and ($sc == $c-1 or $sc == $c+1)) or
+ ($sc == $c and ($sr == $r-1 or $sr == $r+1)) ) {
+ $SPACE->grid(-column => $c, -row => $r);
+ $piece->grid(-column => $sc, -row => $sr);
+ }
+ if (puz_fini) {
+ my $color = ($SPACE->configure(-activebackground))[3];
+ $SPACE->configure(-image => $SPACE_IMAGE,
+ -activebackground => $color,
+ -background => $color,
+ -relief => 'flat',
+ );
+ foreach (@PUZ) {$_->configure(-command => \&beep)}
+ }
+
+} # end move_piece
+
+sub new_puz {
+
+ srand time;
+ foreach (0..$#ORDER) {$ORDER[$_]->[1] = rand $#ORDER}
+ my @order = sort randomly @ORDER;
+ #@order = @ORDER; # here's how I solve the puzzle (;
+ my($i, $o, $c, $r, $but);
+
+ for($i = 0; $i <= $#PUZ; $i++) {
+ $o = $order[$i]->[0];
+ $but = $PUZ[$o];
+ if ($o == 0) {
+ $but->configure(-background => 'red',
+ -relief => 'sunken',
+ -image => undef,
+ -activebackground => 'red',
+ );
+ } else {
+ $but->configure(-command => [\&move_piece, $but]);
+ }
+ ($c, $r) = xy $i;
+ $but->grid(-column => $c, -row => $r, -sticky => 'nsew');
+ }
+
+} # end new_puz
+
+sub randomly {$a->[1] <=> $b->[1]} # randomize order of puzzle pieces
+
+sub xy {my($n) = @_; ($n % $SIDE, int $n / $SIDE)} # ordinal to X/Y
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/plop.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/plop.pl
new file mode 100644
index 00000000000..bd6f801b03f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/plop.pl
@@ -0,0 +1,381 @@
+# Plot a series of continuous functions on a Perl/Tk Canvas.
+#
+# This program is described in the Perl/Tk column from Volume 1, Issue 1 of
+# The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk
+# distribution with permission. It has been modified slightly to conform
+# to the widget demo standard.
+
+#!/usr/local/bin/perl -w
+#
+# plot_program - plot a series of continuous functions on a Perl/Tk Canvas.
+#
+# Stephen O. Lidie, Lehigh University Computing Center, lusol@Lehigh.EDU
+# 96/01/27.
+#
+# Copyright (C) 1996 - 1998 Stephen O. Lidie. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the same terms as Perl itself.
+
+require 5.002;
+use strict;
+use Tk;
+use Tk::Dialog;
+use Tk::LabEntry;
+eval {require "plop.fnc";}; # user supplied math functions
+
+# Predeclare global subroutines and variables.
+
+sub collect_errors;
+sub display_coordinates;
+sub initialize_canvas;
+sub initialize_dialogs;
+sub initialize_functions;
+sub initialize_menus;
+sub make_menubutton;
+sub plot_functions;
+sub update_functions;
+
+my $VERSION = '1.0';
+
+# The default sample functions and limits, each in a different color.
+
+my (@FUNCTIONS) = ('sin($x)', 'cos($x)', 'exp($x)', '$x', 'int($x)');
+my (@COLORS) = qw(red green blue orange olivedrab magenta black salmon purple);
+my $NUM_COLORS = scalar @COLORS;
+my ($X_MIN, $X_MAX, $Y_MIN, $Y_MAX) = (-5, 5, -5, 5);
+my ($DX, $DY) = ($X_MAX - $X_MIN, $Y_MAX - $Y_MIN);
+
+# Declare constants that configure the plotting area: a square approximately
+# 500 pixels on a side, with left/right and top/bottom margins of 80 pixles
+# where we can paint axes labels. With this layout there is a 340x340 area
+# available for graphs.
+
+my $MIN_PXL = 0; # minimum Canvas pixel coordinate
+my $MAX_PXL = 300; # maximum Canvas pixel coordinate
+my $MARGIN = 80; # margin size, in pixels
+my $ALEN = $MAX_PXL - 2 * $MARGIN; # X/Y axes length, in pixels
+
+# Declare Perl/Tk widgets and other data.
+
+my $CANV; # Canvas widget used for plotting functions
+my $DIALOG_ABOUT; # Dialog widget showing "About" information
+my $DIALOG_USAGE; # Dialog widget describing plot usage
+my $MBF; # Menubutton frame
+my $MW = MainWindow->new; # program's main window
+my $ORIGINAL_CURSOR = ($MW->configure(-cursor))[3]; # restore this cursor
+my $TEXT; # Text widget showing function definitions
+
+# %ERRORS is a hash to collect eval() and -w errors. The keys are the error
+# messages themselves and the values are the number of times a particular
+# error was detected.
+
+my %ERRORS;
+
+# Begin main.
+
+initialize_dialogs;
+initialize_menus;
+initialize_canvas;
+initialize_functions;
+
+# End main.
+
+sub collect_errors {
+
+ # Update the hash %ERRORS with the latest eval() error message. Remove
+ # the eval() line number (it's useless to us) to maintain a compact hash.
+
+ my($error) = @_;
+
+ $error =~ s/eval\s+(\d+)/eval/;
+ $ERRORS{$error}++;
+
+} # end collect_errors
+
+sub display_coordinates {
+
+ # Print Canvas and Plot coordinates.
+
+ my($canvas) = @_;
+
+ my $e = $canvas->XEvent;
+ my($canv_x, $canv_y) = ($e->x, $e->y);
+ my($x, $y);
+ $x = $X_MIN + $DX * (($canv_x - $MARGIN) / $ALEN);
+ $y = $Y_MAX - $DY * (($canv_y - $MARGIN) / $ALEN);
+ print STDOUT "\nCanvas x = $canv_x, Canvas y = $canv_y.\n";
+ print STDOUT "Plot x = $x, Plot y = $y.\n";
+
+} # end display_coordinates
+
+sub initialize_canvas {
+
+ # Create the Canvas widget and draw axes and labels.
+
+ my($label_offset, $tick_length) = (20, 5);
+
+ $CANV = $MW->Canvas(
+ -width => $MAX_PXL + $MARGIN * 2,
+ -height => $MAX_PXL,
+ -relief => 'sunken',
+ );
+ $CANV->pack;
+ $CANV->Tk::bind('<Button-1>' => \&display_coordinates);
+
+ $CANV->create('text',
+ 225, 25,
+ -text => 'Plot Continuous Functions Of The Form y=f($x)',
+ -fill => 'blue',
+ );
+
+ # Create the line to represent the X axis and label it. Then label the
+ # minimum and maximum X values and draw tick marks to indicate where they
+ # fall. The axis limits are LabEntry widgets embedded in Canvas windows.
+
+ $CANV->create('line',
+ $MIN_PXL + $MARGIN, $MAX_PXL - $MARGIN,
+ $MAX_PXL - $MARGIN, $MAX_PXL - $MARGIN,
+ );
+
+ $CANV->create('window',
+ $MIN_PXL + $MARGIN, $MAX_PXL - $label_offset,
+ -window => $MW->LabEntry(
+ -textvariable => \$X_MIN,
+ -label => 'X Minimum',
+ -width => 5,
+ ),
+ );
+ $CANV->create('line',
+ $MIN_PXL + $MARGIN, $MAX_PXL - $MARGIN - $tick_length,
+ $MIN_PXL + $MARGIN, $MAX_PXL - $MARGIN + $tick_length,
+ );
+
+ $CANV->create('window',
+ $MAX_PXL - $MARGIN, $MAX_PXL - $label_offset,
+ -window => $MW->LabEntry(
+ -textvariable => \$X_MAX,
+ -label => 'X Maximum',
+ -width => 5,
+ ),
+ );
+ $CANV->create('line',
+ $MAX_PXL - $MARGIN, $MAX_PXL - $MARGIN - $tick_length,
+ $MAX_PXL - $MARGIN, $MAX_PXL - $MARGIN + $tick_length,
+ );
+
+ # Create the line to represent the Y axis and label it. Then label the
+ # minimum and maximum Y values and draw tick marks to indicate where they
+ # fall. The axis limits are LabEntry widgets embedded in Canvas windows.
+
+ $CANV->create('line',
+ $MAX_PXL - $MARGIN, $MIN_PXL + $MARGIN,
+ $MAX_PXL - $MARGIN, $MAX_PXL - $MARGIN,
+ );
+
+ $CANV->create('window',
+ $MAX_PXL + $label_offset, $MIN_PXL + $MARGIN,
+ -window => $MW->LabEntry(
+ -textvariable => \$Y_MAX,
+ -label => 'Y Maximum',
+ -width => 5,
+ ),
+ );
+ $CANV->create('line',
+ $MAX_PXL - $MARGIN - $tick_length, $MIN_PXL + $MARGIN,
+ $MAX_PXL - $MARGIN + $tick_length, $MIN_PXL + $MARGIN,
+ );
+
+ $CANV->create('window',
+ $MAX_PXL + $label_offset, $MAX_PXL - $MARGIN,
+ -window => $MW->LabEntry(
+ -textvariable => \$Y_MIN,
+ -label => 'Y Minimum',
+ -width => 5,
+ ),
+ );
+ $CANV->create('line',
+ $MAX_PXL - $MARGIN - $tick_length, $MAX_PXL - $MARGIN,
+ $MAX_PXL - $MARGIN + $tick_length, $MAX_PXL - $MARGIN,
+ );
+
+} # end initialize_canvas
+
+sub initialize_dialogs {
+
+ # Create all application Dialog objects.
+
+ $DIALOG_ABOUT = $MW->Dialog(
+ -title => 'About',
+ -text =>
+"plot_program $VERSION\n\n95/12/04\n\nThis program is described in the Perl/Tk column from Volume 1, Issue 1 of The Perl Journal (http://tpj.com/tpj), and is included in the Perl/Tk distribution with permission.",
+ -bitmap => 'info',
+ -buttons => ['Dismiss'],
+ );
+ $DIALOG_ABOUT->configure(-wraplength => '6i');
+ $DIALOG_USAGE = $MW->Dialog(
+ -title => 'Usage',
+ -buttons => ['Dismiss'],
+ );
+ $DIALOG_USAGE->Subwidget('message')->configure(
+ -wraplength => '4i',
+ -text => "plot_program iterates over the range of values X Minimum to X Maximum, setting the variable \$x to each value in turn, then evaluates each f(\$x) and paints a point on the Y axis. The X axis increment is (Xmax - Xmin) / $ALEN.\n\nJust enter your functions in the Text widget and click the Plot button.\n\nYou can define a file named \"plop.fnc\" that contains additional private math functions, which is automatically \"require\"d by plot_program. In this file are your private functions that you can plot.\n\nPressing button one on the pointing device displays on standard output the current canvas and plot X and Y coordinates.",
+ );
+
+} # end initialize_dialogs
+
+sub initialize_functions {
+
+ # Pack a spacer Frame and then display instructions in a Label widget.
+
+# $MW->Frame(-height => 10)->pack;
+ $MW->Label(
+ -text => 'Enter your functions here',
+ -foreground => 'blue',
+ )->pack;
+
+ # Create a Frame with a scrollable Text widget that displays the function
+ # list, and a Button to initiate plot activities.
+
+ my $functions_frame = $MW->Frame;
+ $functions_frame->pack;
+ $TEXT = $functions_frame->Text(-height => 3);
+ $TEXT->pack;
+ $functions_frame->AddScrollbars($TEXT);
+ $functions_frame->configure(-scrollbars => 'e');
+ update_functions;
+
+ my $buttons_frame = $MW->Frame;
+ $buttons_frame->pack(-padx => 10, -pady => 5, -expand => 1, -fill => 'x');
+ my @pack_attributes = qw(-side left -fill x -expand 1);
+ $buttons_frame->Button(
+ -text => 'Plot',
+ -command => \&plot_functions,
+ )->pack(@pack_attributes);
+
+} # end initialize_functions
+
+sub initialize_menus {
+
+ # Create the Menubuttons and their associated Menu items.
+
+ $MBF = $MW->Frame(-relief => 'raised', -borderwidth => 1);
+ $MBF->pack(-fill => 'x');
+
+ make_menubutton($MBF, 'File', 0, 'left',
+ [
+ ['Quit', [$MW => 'bell'], 0],
+ ],
+ );
+ make_menubutton($MBF, 'Help', 0, 'right',
+ [
+ ['About', [$DIALOG_ABOUT => 'Show'], 0],
+ ['', undef, 0],
+ ['Usage', [$DIALOG_USAGE => 'Show'], 0],
+ ],
+ );
+
+} # end initialize_menus
+
+sub make_menubutton {
+
+ # Make a Menubutton widget; note that the Menu is automatically created.
+ # If the label is '', make a separator.
+
+ my($mbf, $mb_label, $mb_label_underline, $pack, $mb_list_ref) = @_;
+
+ my $mb = $mbf->Menubutton(
+ -text => $mb_label,
+ -underline => $mb_label_underline,
+ );
+ my $mb_list;
+ foreach $mb_list (@{$mb_list_ref}) {
+ $mb_list->[0] eq '' ? $mb->separator :
+ $mb->command(
+ -label => $mb_list->[0],
+ -command => $mb_list->[1],
+ -underline => $mb_list->[2],
+ );
+ }
+ $mb->pack(-side => $pack);
+
+} # end make_menubutton
+
+sub plot_functions {
+
+ # Plot all the functions.
+
+ my($x, $y, $canv_x, $canv_y) = (0, 0, 0, 0);
+ $canv_x = $MIN_PXL + $MARGIN; # X minimum
+ $MW->configure(-cursor => 'watch');
+ $DX = $X_MAX - $X_MIN; # update delta X
+ $DY = $Y_MAX - $Y_MIN; # update delta Y
+ $CANV->delete('plot'); # erase all previous plots
+
+ # Fetch the newline-separated Text widget contents and update the function
+ # list @FUNCTIONS. Also update the Text widget with the new colors.
+
+ @FUNCTIONS = ();
+ foreach (split /\n/, $TEXT->get('0.0', 'end')) {
+ next if $_ eq '';
+ push @FUNCTIONS, $_;
+ }
+ update_functions;
+ $MW->idletasks;
+
+ %ERRORS = ();
+ local $SIG{'__WARN__'} = sub {collect_errors($_[0])};
+
+ALL_X_VALUES:
+ for ($x = $X_MIN; $x <= $X_MAX; $x += ($X_MAX - $X_MIN) / $ALEN) {
+
+ ALL_FUNCTIONS:
+ foreach (0 .. $#FUNCTIONS) {
+ next if $FUNCTIONS[$_] =~ /^ERROR:/;
+ $y = eval $FUNCTIONS[$_];
+ if ($::EVAL_ERROR) {
+ collect_errors($::EVAL_ERROR);
+ next;
+ }
+ $canv_y = (($Y_MAX - $y) / $DY) * $ALEN + $MARGIN;
+ $CANV->create('text', $canv_x, $canv_y,
+ -fill => $COLORS[$_ % $NUM_COLORS],
+ -tags => ['plot'],
+ -text => '.',
+ ) if $canv_y > $MIN_PXL + $MARGIN and
+ $canv_y < $MAX_PXL - $MARGIN;
+ } # forend ALL_FUNCTIONS
+
+ $canv_x++; # next X pixel
+
+ } # forend ALL_X_VALUES
+
+ $MW->configure(-cursor => $ORIGINAL_CURSOR);
+ $MW->idletasks;
+
+ # Print all the eval() errors to alert the user of malformed functions.
+
+ print STDOUT "\n" if %ERRORS;
+ foreach (keys %ERRORS) {
+ print STDOUT "$ERRORS{$_} occurrences of $_";
+ }
+
+} # end plot_functions
+
+sub update_functions {
+
+ # Insert the function list into the Text widget.
+
+ $TEXT->delete('0.0', 'end');
+ my $i = 0;
+ foreach (@FUNCTIONS) {
+ $TEXT->insert('end', "$_\n", [$i]);
+ $TEXT->tagConfigure($i,
+ -foreground => $COLORS[$i % $NUM_COLORS],
+ -font => 'fixed',
+ );
+ $i++;
+ }
+ $TEXT->yview('end');
+
+} # end update_function_list