<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!/afs/athena/contrib/perl5/perl

use English;
use Tk;

#$font = "-Adobe-times-medium-r-normal-";
%fonts = ('Symbol', '-*-symbol-*-*-*-*-',
	  'Times' =&gt; '-*-times-*-*-*-*-',
	  'Tymes' =&gt; '-*-tymes-*-*-*-*-',
	  'Generic' =&gt; '-*-*-*-*-*-',
	  );

@sizes = (10, 12, 18, 24, 36, 48, 60, 72, 100);


# Control Window
my $newtext = MainWindow-&gt;new();

my $f1 = $newtext-&gt;Frame;
my $f2 = $newtext-&gt;Frame;

my $textentry = $f1-&gt;Entry(-textvariable =&gt; \$text);

$textentry-&gt;bind("&lt;Return&gt;" =&gt; \&amp;addtext);
$textentry-&gt;pack(-side =&gt; 'left',
		 -padx =&gt; 10,
		 -pady =&gt; 5,
		 -fill =&gt; 'y');

my $but = $f1-&gt;Button(-text =&gt; 'Add',
			   -command =&gt; \&amp;addtext);

$but-&gt;pack(-side =&gt; "right");

my $f3 = $f2-&gt;Frame;
my $f4 = $f2-&gt;Frame;
$f3-&gt;pack(-side =&gt; top);
$f4-&gt;pack(-side =&gt; bottom);

$sb = $f3-&gt;Scrollbar;
$sb-&gt;pack(-side =&gt; 'left',
	  -fill =&gt; 'y');

$lb = $f3-&gt;Listbox(-yscrollcommand =&gt; [$sb =&gt; 'set'],
			-width          =&gt; 20,
			-height         =&gt; 3,
			);
$lb-&gt;pack();
$sb-&gt;configure(-command =&gt; [$lb =&gt; 'yview']);

#$lb-&gt;bind("&lt;1&gt;" =&gt; sub { $font_a = $fonts{$_[0]-&gt;get('active')};});

$lb-&gt;insert(0, keys %fonts);

$ssb = $f4-&gt;Scrollbar;
$ssb-&gt;pack(-side =&gt; 'left',
	  -fill =&gt; 'y');

$slb= $f4-&gt;Listbox(-yscrollcommand =&gt; [$ssb =&gt; 'set'],
			-width          =&gt; 20,
			-height         =&gt; 3,
			);
$slb-&gt;pack();
$ssb-&gt;configure(-command =&gt; [$slb =&gt; 'yview']);

#$slb-&gt;bind("&lt;1&gt;" =&gt; sub { $font_b = $_[0]-&gt;get('active');});

$slb-&gt;insert(0, @sizes);

$f1-&gt;pack(-side =&gt; top);
$f2-&gt;pack(-side =&gt; bottom);

# View Window

my $win = MainWindow-&gt;new;

my $canvas = $win-&gt;Canvas(-height =&gt; "11i",
			  -width =&gt; "8.5i");

$canvas-&gt;pack();

$c = $canvas;

$c-&gt;Tk::bind("&lt;3&gt;" =&gt; \&amp;printme);

sub printme {
    $canvas-&gt;postscript(-file =&gt; "/tmp/pic.ps", -fontmap =&gt; \%fm);
}

$canvas-&gt;create(qw(line 0.2i 0.7i 1.5i 1.4i -tags item));
    $canvas-&gt;bind('item', '&lt;Any-Enter&gt;' =&gt; [\&amp;items_enter, \%iinfo]);
    $canvas-&gt;bind('item', '&lt;Any-Leave&gt;' =&gt; [\&amp;items_leave, \%iinfo]);
    $canvas-&gt;Tk::bind('&lt;1&gt;' =&gt; sub {
	my($c) = @ARG;
        my $e = $c-&gt;XEvent;
	&amp;items_start_drag( $c, $e-&gt;x, $e-&gt;y, \%iinfo);
    });
    $canvas-&gt;Tk::bind('&lt;B1-Motion&gt;' =&gt; sub {
	my($c) = @ARG;
        my $e = $c-&gt;XEvent;
	&amp;items_drag( $c, $e-&gt;x, $e-&gt;y, \%iinfo);
    });

sub addtext {
    print("Lbcurselection: ", $slb-&gt;curselection, "\n");
    $font_a = $fonts{$lb-&gt;get($lb-&gt;curselection, 0)};
    $font_b = $fonts{$slb-&gt;get($slb-&gt;curselection,0)};
    $it = $c-&gt;create(qw(text 1i 1i), 
	       -text =&gt; $text,
	       -font =&gt; $font_a.$font_b."-*-*-*-*-*-*-*",
	       -tags =&gt; item);
    $fm{$font_a.$font_b."-*-*-*-*-*-*-*"} = "Times-Roman";
    print("Created item $it\n");
    $text = "";
}

sub items_drag {

    my($c, $x, $y, $iinfo) = @ARG;

    $x = $c-&gt;canvasx($x);
    $y = $c-&gt;canvasy($y);
    $c-&gt;move('current', $x-$iinfo-&gt;{'lastX'}, $y-$iinfo-&gt;{'lastY'});
    $iinfo-&gt;{'lastX'} = $x;
    $iinfo-&gt;{'lastY'} = $y;

} # end items_drag
sub items_start_drag {

    my($c, $x, $y, $iinfo) = @ARG;

    $iinfo-&gt;{'lastX'} = $c-&gt;canvasx($x);
    $iinfo-&gt;{'lastY'} = $c-&gt;canvasy($y);

} # end items_start_drag

sub items_enter {

    my($c, $iinfo) = @ARG;

    $iinfo-&gt;{'restore_cmd'} = '';

    if ($win-&gt;depth == 1) {
	$iinfo-&gt;{'restore_cmd'} = '';
	return;
    }
    my $type = $c-&gt;type('current');
    if ($type eq 'window') {
	$iinfo-&gt;{'restore_cmd'} = '';
	return;
    }

    if ($type eq 'bitmap') {
	my $bg = ($c-&gt;itemconfigure('current', -background))[4];
	if (defined $bg) {
	    $iinfo-&gt;{'restore_cmd'} = "\$c-&gt;itemconfigure('current',
                -background =&gt; '$bg');";
	} else {
	    $iinfo-&gt;{'restore_cmd'} = "\$c-&gt;itemconfigure('current',
                -background =&gt; undef);";
	}
	$c-&gt;itemconfigure('current', -background =&gt; 'SteelBlue2');
	return;
    }
    my $fill = ($c-&gt;itemconfigure('current', -fill))[4];
    if (($type eq 'rectangle' or $type eq 'oval' or $type eq 'arc')
	    and not defined $fill) {
	my $outline = ($c-&gt;itemconfigure('current', -outline))[4];
	$iinfo-&gt;{'restore_cmd'} = "\$c-&gt;itemconfigure('current',
            -outline =&gt; '$outline')";
	$c-&gt;itemconfigure('current', -outline =&gt; 'SteelBlue2');
    } else {
	$iinfo-&gt;{'restore_cmd'} = "\$c-&gt;itemconfigure('current',
            -fill =&gt; '$fill')";
	$c-&gt;itemconfigure('current', -fill =&gt; 'SteelBlue2');
    }

} # end items_enter
sub items_leave {

    my($c, $iinfo) = @ARG;

    eval $iinfo-&gt;{'restore_cmd'};

} # end items_leave

MainLoop;
</pre></body></html>