diff options
author | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
commit | b56b320b5e2515160073fa1b469514002688fe11 (patch) | |
tree | 965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/lib/Tk/demos/widtrib | |
parent | d26c206452d2e285c3bbf949f34011e4a55fd8f9 (diff) |
tlperl 5.22.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751
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 | 331 | ||||
-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 | 26699 -> 0 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, 0 insertions, 1539 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Gedi.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Gedi.pl deleted file mode 100644 index ff847000e05..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Gedi.pl +++ /dev/null @@ -1,429 +0,0 @@ -# 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 deleted file mode 100644 index f0415ea9cae..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/TEMPLATE.pl +++ /dev/null @@ -1,92 +0,0 @@ -# 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 deleted file mode 100644 index c9a44b8c0b1..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/Tiler.pl +++ /dev/null @@ -1,15 +0,0 @@ -# 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 deleted file mode 100644 index 482bb46ea5b..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl +++ /dev/null @@ -1,331 +0,0 @@ -# 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 three sections: core Tk modules and Tix 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, - ); - } - $w->configure(-scrollregion => [$w->bbox("all")]); - }, - }, - {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 - - {separator => 'Tix modules'}, - - 'FloatEntry', - {class => 'HList', action => sub { - my $w = shift; - my $b = $w->Balloon; - my %binfo; - for my $path ('1', '1.1', '1.2', '2', '2.1') { - $w->add($path, -text => $path); - $binfo{$path} = "BalloonInfo: $path"; - } - $b->attach($w, -balloonposition => "mouse", -msg => \%binfo); - }, - }, - qw(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 deleted file mode 100644 index 645f1433d54..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/cursor.pl +++ /dev/null @@ -1,65 +0,0 @@ -# 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 differdeleted file mode 100644 index c5c8318d145..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/lib/npuz/Xcamel.npuz +++ /dev/null diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl deleted file mode 100644 index 3a6ba17f937..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/npuz.pl +++ /dev/null @@ -1,226 +0,0 @@ -# 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 deleted file mode 100644 index bd6f801b03f..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/plop.pl +++ /dev/null @@ -1,381 +0,0 @@ -# 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 |