diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widtrib')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Gedi.pl | 429 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/TEMPLATE.pl | 92 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Tiler.pl | 15 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl | 315 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/cursor.pl | 65 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz | bin | 0 -> 26699 bytes | |||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl | 226 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widtrib/plop.pl | 381 |
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 Binary files differnew file mode 100644 index 00000000000..c5c8318d145 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz 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 |