home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _1d06fcf23c5c8e0c044d2b06874a9d1d < prev    next >
Text File  |  2004-06-01  |  14KB  |  359 lines
  1. # items.pl
  2.  
  3. use subs qw/items_button_press items_drag items_enter items_leave items_mark
  4.         items_start_drag items_stroke items_under_area/;
  5. use vars qw/$TOP/;
  6.  
  7. sub items {
  8.  
  9.     # Create a top-level window containing a canvas that displays the various
  10.     # item types and allows them to be selected and moved.
  11.  
  12.     my($demo) = @_;
  13.     $TOP = $MW->WidgetDemo(
  14.         -name     => $demo,
  15.         -text     => ["This window contains a canvas widget with examples of the various kinds of items supported by canvases.  The following operations are supported:\n  Button-1 drag:\tmoves item under pointer.\n  Button-2 drag:\trepositions view.\n  Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tdisplays items under area.", qw/-wraplength 5i/],
  16.         -title    => 'Canvas Item Demonstration',
  17.         -iconname => 'items',
  18.     );
  19.  
  20.     my $c = $TOP->Scrolled(qw/Canvas -width 15c -height 10c -relief sunken
  21.                -borderwidth 2 -scrollbars se -scrollregion/ =>
  22.                [qw/0c 0c 30c 24c/]);
  23.     $c->pack(qw/-expand yes -fill both/);
  24.  
  25.     my %iinfo = ();        # item information hash
  26.     $iinfo{areaX1} = 0;
  27.     $iinfo{areaY1} = 0;
  28.     $iinfo{areaX2} = 0;
  29.     $iinfo{areaY2} = 0;
  30.     $iinfo{restore_cmd} = '';
  31.  
  32.  
  33.     if ($Tk::VERSION cmp '800.015') {
  34.     # Display a 3x3 rectangular grid (800.016 or greater).
  35.     $c->createGrid(qw/0c  0c 10c 8c -width 2 -lines 1/);
  36.     $c->createGrid(qw/0c  0c 5c  4c -lines 1 -dash ./);
  37.     $c->createGrid(qw/0c  0c 10m 8m -width 1/);
  38.     } else {
  39.     # Display a 3x3 rectangular grid.
  40.     $c->createRectangle(qw/ 0c  0c 30c 24c -width 2/);
  41.     $c->createLine     (qw/ 0c  8c 30c  8c -width 2/);
  42.     $c->createLine     (qw/ 0c 16c 30c 16c -width 2/);
  43.     $c->createLine     (qw/10c  0c 10c 24c -width 2/);
  44.     $c->createLine     (qw/20c  0c 20c 24c -width 2/);
  45.     }
  46.  
  47.     my $font1 = '-*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*';
  48.     my $font2 = '-*-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*';
  49.     my($blue, $red, $bisque, $green);
  50.     if ($TOP->depth > 1) {
  51.     $blue = 'DeepSkyBlue3';
  52.     $red = 'red';
  53.     $bisque = 'bisque3';
  54.     $green = 'SeaGreen3';
  55.     } else {
  56.     $blue = 'black';
  57.     $red = 'black';
  58.     $bisque = 'black';
  59.     $green = 'black';
  60.     }
  61.  
  62.     # Set up demos within each of the areas of the grid.
  63.  
  64.     $c->createText(qw/5c .2c -text Lines -anchor n/);
  65.     $c->createLine(qw/1c 1c 3c 1c 1c 4c 3c 4c -width 2m/, -fill => $blue,
  66.            qw/-cap butt -join miter -tags item/);
  67.     $c->createLine(qw/4.67c 1c 4.67c 4c -arrow last -activedash - -tags item/);
  68.     $c->createLine(qw/6.33c 1c 6.33c 4c -arrow both -activedash . -tags item/);
  69.     $c->createLine(qw/5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c
  70.                    8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c
  71.                8.4c 4.4c -width 3 -tags item -fill/ => $red);
  72.     $c->createLine(qw/1c 5c 7c 5c 7c 7c 9c 7c -width .5c/,
  73.                -stipple => '@'.Tk->findINC('demos/images/grey.25'),
  74.                qw/-arrow both -tags item -arrowshape/ => [15, 15, 7]);
  75.     $c->createLine(qw/1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c
  76.                -cap round -join round -tags item/);
  77.  
  78.     $c->createText(qw/15c .2c -anchor n -text/ => 'Curves (smoothed lines)');
  79.     $c->createLine(qw/11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on/,
  80.                -fill =>$blue, qw/-tags item/);
  81.     $c->createLine(qw/15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on
  82.                -arrow both -width 3 -tags item/);
  83.     $c->createLine(qw/12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c
  84.                7.5c 12c 6c -smooth on -width 3m -cap round -tags item/,
  85.                -stipple => '@'.Tk->findINC('demos/images/grey.25'),
  86.                -fill => $red);
  87.  
  88.     $c->createText(qw/25c .2c -text Polygons -anchor n/);
  89.     $c->createPolygon(qw/21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c 4.0c
  90.                       22.5c 3.25c 21c 4.0c 21.75c 2.5c -tags item/,
  91.                   -fill => $green);
  92.     $c->createPolygon(qw/25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c
  93.                   29c 4c 29c 4c -smooth on -tags item/, -fill => $red);
  94.     $c->createPolygon(qw/22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c
  95.                   5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c -tags item/,
  96.                   -stipple => '@'.Tk->findINC('demos/images/grey.25'));
  97.  
  98.     $c->createText(qw/5c 8.2c -text Rectangles -anchor n/);
  99.     $c->createRectangle(qw/1c 9.5c 4c 12.5c/, -outline => $red,
  100.                     qw/-width 3m -tags item/);
  101.     $c->createRectangle(qw/0.5c 13.5c 4.5c 15.5c/, -fill => $green,
  102.                     qw/-tags item/);
  103.     $c->createRectangle(qw/6c 10c 9c 15c -tags item/, -outline => undef,
  104.                     -stipple => '@'.Tk->findINC('demos/images/grey.25'),
  105.                     -fill => $blue);
  106.  
  107.     $c->createText(qw/15c 8.2c -text Ovals -anchor n/);
  108.     $c->createOval(qw/11c 9.5c 14c 12.5c/, -outline => $red,
  109.                qw/-width 3m -tags item/);
  110.     $c->createOval(qw/10.5c 13.5c 14.5c 15.5c/, -fill => $green,
  111.                qw/-tags item/);
  112.     $c->createOval(qw/16c 10c 19c 15c -tags item/, -outline => undef,
  113.                -stipple => '@'.Tk->findINC('demos/images/grey.25'),
  114.                -fill => $blue);
  115.  
  116.     $c->createText(qw/25c 8.2c -text Text -anchor n/);
  117.     $c->createRectangle(qw/22.4c 8.9c 22.6c 9.1c/);
  118.     $c->createText(qw/22.5c 9c -anchor n -width 4c/, -font => $font1,
  119.                -text => 'A short string of text, word-wrapped, justified left, and anchored north (at the top).  The rectangles show the anchor points for each piece of text.', qw/-tags item/);
  120.     $c->createRectangle(qw/25.4c 10.9c 25.6c 11.1c/);
  121.     $c->createText(qw/25.5c 11c -anchor w/, -font => $font1, -fill => $blue,
  122.                -text => "Several lines,\n each centered\n" .
  123.                "individually,\nand all anchored\nat the left edge.",
  124.                qw/-justify center -tags item/);
  125.     $c->createRectangle(qw/24.9c 13.9c 25.1c 14.1c/);
  126.     $c->createText(qw/25c 14c -anchor c/, -font => $font2, -fill => $red,
  127.                -stipple => 'gray50',
  128.                -text => 'Stippled characters', qw/-tags item/);
  129.  
  130.     $c->createText(qw/5c 16.2c -text Arcs -anchor n/);
  131.     $c->createArc(qw/0.5c 17c 7c 20c/, -fill => $green, qw/-outline black/,
  132.               -stipple => '@'.Tk->findINC('demos/images/grey.25'),
  133.               qw/-start 45 -extent 270 -style pieslice -tags item/);
  134.     $c->createArc(qw/6.5c 17c 9.5c 20c -width 4m -style arc/, -fill => $blue,
  135.               qw/-start -135 -extent 270 -tags item/);
  136.     $c->createArc(qw/0.5c 20c 9.5c 24c -width 4m -style pieslice/,
  137.               -fill => undef, -outline => $red,
  138.               qw/-start 225 -extent -90 -tags item/);
  139.     $c->createArc(qw/5.5c 20.5c 9.5c 23.5c -width 4m -style chord/,
  140.               -fill => $blue, -outline => undef,
  141.               qw/-start 45 -extent 270  -tags item/);
  142.  
  143.     $c->createText(qw/15c 16.2c -text Bitmaps -anchor n/);
  144.     $c->createBitmap(qw/13c 20c -bitmap/ =>
  145.                      '@'.Tk->findINC('demos/images/face'), qw/-tags item/);
  146.     $c->createBitmap(qw/17c 18.5c/,
  147.                  -bitmap => '@'.Tk->findINC('demos/images/noletters'),
  148.                  qw/-tags item/);
  149.     $c->createBitmap(qw/17c 21.5c/,
  150.                  -bitmap => '@'.Tk->findINC('demos/images/letters'),
  151.                  qw/-tags item/);
  152.  
  153.     $c->createText(qw/25c 16.2c -text Windows -anchor n/);
  154.     my $c_button = $c->Button(-text => 'Press Me',
  155.         -command => [\&items_button_press, $c, $red],
  156.     );
  157.     $c->createWindow(qw/21c 18c/, -window => $c_button,
  158.                  qw/-anchor nw -tags item/);
  159.     my $c_entry = $c->Entry(-width => '20', -relief => 'sunken',
  160.                             -validate => 'all',
  161.                             -validatecommand => sub {$n++ ? 1 : 0},
  162.                             -invalidcommand => sub {$TOP->bell});
  163.     $c_entry->insert('end' => 'Edit this text');
  164.     $c->createWindow(qw/21c 21c/, -window => $c_entry,
  165.                  qw/-anchor nw -tags item/);
  166.     my $c_scale = $c->Scale(qw/-from 0 -to 100 -length 6c -sliderlength .4c
  167.                 -width .5c -tickinterval 0/);
  168.     $c->createWindow(qw/28.5c 17.5c/, -window => $c_scale,
  169.                  qw/-anchor n -tags item/);
  170.     $c->createText(qw/21c 17.9c -text Button: -anchor sw/);
  171.     $c->createText(qw/21c 20.9c -text Entry: -anchor sw/);
  172.     $c->createText(qw/28.5c 17.4c -text Scale: -anchor s/);
  173.  
  174.     # Set up event bindings for canvas.
  175.  
  176.     $c->bind('item', '<Any-Enter>' => [\&items_enter, \%iinfo]);
  177.     $c->bind('item', '<Any-Leave>' => [\&items_leave, \%iinfo]);
  178.  
  179.     # Get real canvas widget reference to apply bind() commands to:  the
  180.     # Canvas widget is a subwidget of the Scrolled composite widget.  To
  181.     # reference the X event structure, either use the XEvent() method or
  182.     # read the specially localized variable $Tk::event.  We'll use XEvent
  183.     # first, and the variable from then on.
  184.  
  185.     $c->CanvasBind('<<Copy>>',sub { print "Do Copy\n" });
  186.  
  187.     $c->CanvasBind('<1>' => sub {
  188.     my($c) = @_;
  189.         my $e = $c->XEvent;
  190.     items_start_drag $c, $e->x, $e->y, \%iinfo;
  191.     });
  192.     $c->CanvasBind('<B1-Motion>' =>
  193.         sub {items_drag shift, $Tk::event->x, $Tk::event->y, \%iinfo});
  194.     $c->CanvasBind('<2>' =>
  195.         sub {shift->scan('mark', $Tk::event->x, $Tk::event->y)});
  196.     $c->CanvasBind('<B2-Motion>' =>
  197.          sub {shift->scan('dragto', $Tk::event->x, $Tk::event->y)});
  198.     $c->CanvasBind('<3>' =>
  199.          sub {items_mark shift, $Tk::event->x, $Tk::event->y, \%iinfo});
  200.     $c->CanvasBind('<B3-Motion>' =>
  201.          sub {items_stroke shift, $Tk::event->x, $Tk::event->y, \%iinfo});
  202.     $c->CanvasBind('<Control-f>' => [sub {
  203.     my($c, $iinfo) = @_;
  204.         my $e = $c->XEvent;
  205.     items_under_area $c, $iinfo;
  206.     }, \%iinfo]);
  207.     $c->CanvasBind('<Any-Enter>' => sub {$_[0]->CanvasFocus});
  208.  
  209. } # end items
  210.  
  211. # Utility procedures for highlighting the item under the pointer:
  212.  
  213. sub items_button_press {
  214.  
  215.     # Procedure that's invoked when the button embedded in the canvas
  216.     # is invoked.
  217.  
  218.     my($w, $color) = @_;
  219.  
  220.     my $i = $w->createText(qw/25c 18.1c -anchor n/, -text => 'Ouch!!',
  221.                -fill => $color);
  222.     $w->after(500, sub { $w->delete($i) });
  223.  
  224. } # end items_button_press
  225.  
  226. sub items_drag {
  227.  
  228.     my($c, $x, $y, $iinfo) = @_;
  229.  
  230.     $x = $c->canvasx($x);
  231.     $y = $c->canvasy($y);
  232.     $c->move('current', $x-$iinfo->{lastX}, $y-$iinfo->{lastY});
  233.     $iinfo->{lastX} = $x;
  234.     $iinfo->{lastY} = $y;
  235.  
  236. } # end items_drag
  237.  
  238. sub items_enter {
  239.  
  240.     my($c, $iinfo) = @_;
  241.  
  242.     $iinfo->{restore_cmd} = '';
  243.  
  244.     if ($TOP->depth == 1) {
  245.     $iinfo->{restore_cmd} = '';
  246.     return;
  247.     }
  248.     my $type = $c->type('current');
  249.     if ($type eq 'window') {
  250.     $iinfo->{restore_cmd} = '';
  251.     return;
  252.     }
  253.  
  254.     if ($type eq 'bitmap') {
  255.     my $bg = ($c->itemconfigure(qw/current -background/))[4];
  256.     if (defined $bg) {
  257.         $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
  258.                 -background => '$bg');";
  259.     } else {
  260.         $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
  261.                 -background => undef);";
  262.     }
  263.     $c->itemconfigure(qw/current -background SteelBlue2/);
  264.     return;
  265.     }
  266.     my $fill = ($c->itemconfigure(qw/current -fill/))[4];
  267.     my $stipple = ($c->itemconfigure(qw/current -stipple/))[4];
  268.     if (defined $stipple) {
  269.     $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
  270.             -stipple => '$stipple')";
  271.     $c->itemconfigure(qw/current -stipple /,'');
  272.     } elsif (($type eq 'rectangle' or $type eq 'oval' or $type eq 'arc')
  273.         and not defined $fill) {
  274.     my $outline = ($c->itemconfigure(qw/current -outline/))[4];
  275.     $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
  276.             -outline => '$outline')";
  277.     $c->itemconfigure(qw/current -outline SteelBlue2/);
  278.     } else {
  279.     $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
  280.             -fill => '$fill')";
  281.     $c->itemconfigure(qw/current -fill SteelBlue2/);
  282.     }
  283.  
  284. } # end items_enter
  285.  
  286. sub items_leave {
  287.  
  288.     my($c, $iinfo) = @_;
  289.  
  290.     eval $iinfo->{restore_cmd};
  291.  
  292. } # end items_leave
  293.  
  294. sub items_mark {
  295.  
  296.     my($c, $x, $y, $iinfo) = @_;
  297.  
  298.     $iinfo->{areaX1} = $c->canvasx($x);
  299.     $iinfo->{areaY1} = $c->canvasy($y);
  300.     $c->delete('area');
  301.  
  302. } # end items_mark
  303.  
  304. sub items_start_drag {
  305.  
  306.     my($c, $x, $y, $iinfo) = @_;
  307.  
  308.     $iinfo->{lastX} = $c->canvasx($x);
  309.     $iinfo->{lastY} = $c->canvasy($y);
  310.  
  311. } # end items_start_drag
  312.  
  313. sub items_stroke {
  314.  
  315.     my($c, $x, $y, $iinfo) = @_;
  316.  
  317.     $x = $c->canvasx($x);
  318.     $y = $c->canvasy($y);
  319.     if (($iinfo->{areaX1} != $x) and ($iinfo->{areaY1} != $y)) {
  320.     $c->delete('area');
  321.     $c->addtag('area', 'withtag', $c->create('rectangle',
  322.         $iinfo->{areaX1}, $iinfo->{areaY1}, $x, $y, -outline => 'black'));
  323.     $iinfo->{areaX2} = $x;
  324.     $iinfo->{areaY2} = $y;
  325.     }
  326.  
  327. } # end items_stroke
  328.  
  329. sub items_under_area {
  330.  
  331.     my($c, $iinfo) = @_;
  332.  
  333.     my $area = $c->find('withtag', 'area');
  334.     my @items  = ();
  335.     my $i;
  336.     foreach $i ($c->find('enclosed', $iinfo->{areaX1},
  337.             $iinfo->{areaY1}, $iinfo->{areaX2}, $iinfo->{areaY2})) {
  338.     my @tags = $c->gettags($i);
  339.     if (defined($tags[0]) and grep $_ eq 'item', @tags) {
  340.         push @items, $i;
  341.     }
  342.     }
  343.     @items = 'None' unless @items;
  344.     print STDOUT 'Items enclosed by area:  ', join(' ', @items), ".\n";
  345.     @items = ();
  346.     foreach $i ($c->find('overlapping', $iinfo->{areaX1}, $iinfo->{areaY1},
  347.             $iinfo->{areaX2}, $iinfo->{areaY2})) {
  348.     my @tags = $c->gettags($i);
  349.     if (defined($tags[0]) and grep $_ eq 'item', @tags) {
  350.         push @items, $i;
  351.     }
  352.     }
  353.     @items = 'None' unless @items;
  354.     print STDOUT 'Items overlapping area:  ', join(' ', @items), ".\n";
  355.  
  356. } # end items_under_area
  357.  
  358. 1;
  359.