Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / demos / widtrib / HList2.pl

# HList and ItemStyle, multicolumn listbox with individual cell styles.
# -*- perl -*-

#
# $Id: $
# Author: Slaven Rezic
#
# Copyright (C) 1999 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: eserte@cs.tu-berlin.de
# WWW:  http://user.cs.tu-berlin.de/~eserte/
#

use Tk::HList;
use Tk::ItemStyle;

sub HList2 {
    my($demo) = @_;
    my $TOP = $MW->WidgetDemo(
        -name => $demo,
        -text => 'HList and ItemStyle, multicolumn listbox with individual cell styles.',
	-geometry_manager => 'grid',
    );

    my $h = $TOP->Scrolled
      (qw/HList
       -header 1
       -columns 4
       -width 50
       -height 20/
      )->grid(qw/-sticky nsew/);

    for (0 .. 3) {
	$h->header('create', $_, -text => 'Column ' . $_);
    }

    my @img;
    foreach ('Xcamel.gif', 'anim.gif', 'icon.gif', 'Camel.xpm') {
	push @img, $TOP->Photo(-file => Tk->findINC($_)),
    }

    my(@fonts) = ('-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*',
		  '-*-Courier-Medium-R-Normal--*-180-*-*-*-*-*-*',
		  '-*-times-medium-r-normal--*-240-*-*-*-*-*-*',
		  '-Adobe-Courier-Bold-O-Normal--*-120-*-*-*-*-*-*',
		  'fixed',
		 );

    my(@colors) = qw(red green blue yellow red cyan black);

    my $rnd_font = sub {
	$fonts[rand($#fonts+1)];
    };
    my $rnd_color = sub {
	$colors[rand($#colors+1)];
    };
    my $rnd_image = sub {
	my $yn = int(rand(2));
	if ($yn) {
	    $img[rand($#img+1)];
	} else {
	    undef;
	}
    };
    my $rnd_window = sub {
	return undef; # XXX disable for now
	my $yn = int(rand(10));
	if ($yn == 3) {
	    ('Button', 'Entry')[rand(2)];
	} else {
	    undef;
	}
    };

    for my $y (0 .. 20) {
	my $e = $h->addchild("");
	for my $col (0 .. 3) {
	    my $window = $rnd_window->();
	    my $image = $rnd_image->();
	    my $fg = $rnd_color->();
	    my $bg = $rnd_color->();
	    if ($bg eq $fg) { $fg = 'white' }
	    
	    my $style_type = ($window ? 'window' : 
			      ($image ? 'imagetext' : 'text'));
	    my $btn;
	    my $style = $h->ItemStyle($style_type);
	    if ($style_type eq 'window') {
		$style->configure(-pady => 0, -padx => 0);
		if ($window eq 'Button') {
		    $btn = $h->Button
		      (-text => 'Click me!',
		       -command => sub {
			   $btn->configure(-activeforeground => $rnd_color->());
		       },
		      );
		} else {
		    $btn = $h->Entry;
		}
	    } else {
		$style->configure(-foreground => $fg,
				  -background => $bg,
				  -font       => $rnd_font->(),
				 );
	    }
	    $h->itemCreate
	      ($e, $col,
	       -itemtype => $style_type,
	       -style => $style,
	       ($style_type eq 'imagetext'
		? (-image => $image) : ()
	       ),
	       ($style_type eq 'window'
		? (-widget => $btn) : (-text => 'Cell ' . $y . '/' . $col)
	       ),
	      );
	}
    }
}                

1;

__END__