#!/usr/bin/perl -w

=head1 NAME 

ptkfonted - Perl/Tk BDF format font editor

=head1 VERSION

v0.4 (helvetica)

=head1 SYNOPSIS

ptkfonted

=head1 REQUIREMENTS

=over 4

=item *

Tk.pm (I'm using Perl/Tk 800.014 - not sure
how well it will work on earlier versions)

=item *

Font::BDF.pm v0.1 or newer (Latest version obtainable at F<http://cantor.res.cmu.edu/>)

=back

=head1 DESCRIPTION

This is ptkfonted, a scratch to one of my itches:
Editing BDF files by hand is all but impossible,
xfedor is a total nightmare, and xmbdfed is klunky,
and lesstif doesn't like it anyway. It seemed I might
as well just write a BDF editor in Perl/Tk. 

So I did.

General warning: Very alpha code. Watch your step.

The interface should be relatively intuitive.
You can open, edit, and save bdf files using
the obvious B<File> menu commands. (some
are included in F<fonts/>) The glyphs in
a font are displayed in the main window, labelled by
default with the literal character corresponding
to them; you can change this to the decimal,
octal, or hex equivalent under B<Options-E<gt>Encoding Format>.

To edit an individual character, click on its
cell in the main window.  A character editing
window should appear. 
You can move to the next
and previous characters with the corresponding
commands in the B<Character> menu.

Left-clicking and dragging in the grid inside
the character editing window changes the working
copy character's bitmap. You can select rectangular
regions of the bitmap with the right button, and
move selected pixels around with the left button.
B<Edit-E<gt>Cut>, B<-E<gt>Copy>, B<-E<gt>Paste>, and
B<-E<gt>Clear> behave as you would expect, hopefully.
(If not, then maybe your expectations need to
be revised :)

To commit the changes
to a character, do B<Character-E<gt>Update> (shortcut
key 'u'). An emacs-style indicator at the bottom
left is '**' if there are changes that haven't
been updated yet, and '--' otherwise. Once updated,
the character should appear, actual size, in the
main window in the appropriate place.

You can also use B<Options-E<gt>Update Mode> 
to make changes automatically updated whenever you
move to the next or previous character (B<Always autoupdate>)
or automatically discard changes (B<Never autoupdate>)
or, the default, ask whether to update upon moving
between characters while there are unupdated changes.
 
B<Options-E<gt>View> changes the size of the grid
(both in terms of how many cells there are and how
big the cells are). B<Options-E<gt>Grid> and B<Axes>
should be obvious. B<Options-E<gt>Encoding Format> works
identically to the menu item of the same name
in the main window, except on the current character indicator 
at the bottom of the character editing window.

B<Character-E<gt>Info> and everything in the B<Font>
menu in the main window pertain to how X deals
with fonts. If you a) don't know how it works b) want
to and c) don't feel that the XLFD spec is great lazy
sunday afternoon reading, email me, and I can 
fill in the details.

=cut

use Tk;
use Tk::FBox qw(as_default);
use Tk::Widget;
use Tk::Canvas;
use Tk::Derived;
use Tk::LabEntry;
use Tk::DialogBox;
use Tk::HList;
use Tk::ItemStyle;
use Font::BDF;
BEGIN {
  eval { require Tk::Pod; import Tk::Pod () };
  $have_pod = !$@; 
}

###############################
# TitleScalar

package TitleScalar;

sub TIESCALAR {
    my $class = shift;
	my ($window, $prefix, $undef_prefix) = @_;
    return bless {value => undef,  window => $window, 
				  prefix => $prefix, undef_prefix => $undef_prefix} => $class;
}

sub FETCH {
  $_[0]{value};
}

sub STORE {
  my $self = shift;
  my ($v) = @_;
  $self->{window}->configure(-title => (defined $v ? $self->{prefix} . $v : $self->{undef_prefix}));
  $self->{value} = $v;
}

###############################
# Bitmap Editor Widget

# Maybe I should spin this off as
# a module unto itself...

package Tk::BitmapEdit;

use POSIX qw(floor ceil);

use base qw(Tk::Derived Tk::Canvas);

Construct Tk::Widget "BitmapEdit";

# main methods

sub InitObject {
  my ($w, $args) = @_;
  
  $w->ConfigSpecs
    (
     -view =>       ["METHOD",   undef, undef, [16, 0, -5, 7, 11]],
     -axes =>       ["METHOD",   undef, undef, 1],
     -axes_color => ["METHOD",   undef, undef, "red"],
     -grid =>       ["METHOD",   undef, undef, 1],
     -dirty =>      ["CALLBACK", undef, undef, undef],
    );
  
  $w->SUPER::InitObject($args);
  
  $w->{dirty} = "";

  # Axes
  $w->{x_axis} = $w->createLine(0, 0, 0, 0);
  $w->{y_axis} = $w->createLine(0, 0, 0, 0);

  # Selection
  $w->{sel}{back} = $w->createLine(0,0,0,0, -fill => "white", -tags => ["selection"]);
  $w->{sel}{fore} = $w->createLine(0,0,0,0, -fill => "black", -tags => ["selection"]);
  
  # Bindings
  $w->bind("cell", "<Button-1>", \&handle_1_click );
  $w->bind("cell", "<Button1-Motion>", \&handle_1_drag );

  $w->bind("cell", "<Button-2>", \&handle_2_click );

  $w->CanvasBind("<ButtonPress-3>", \&handle_3_click);
  $w->CanvasBind("<Button3-Motion>", \&handle_3_drag);
  $w->CanvasBind("<ButtonRelease-3>", \&handle_3_release);

  # Set up marching ants bitmaps and state
  $w->init_marching_ants();
  $w->{ma} = 0;

  $w;
}

{
  # Just a bit of a hack to make sure bitmaps
  # are initialized exactly once.
  my $deja_vu = 0;

  # Apparently DefineBitmap doesn't do a deep enough
  # copy, since if Perl ever GCs the bitmap you pass in,
  # you get garbage on screen. Grr. We'll just stick
  # 'em in a lexical.
  my @bits;

  sub init_marching_ants {
    my $self = shift;
    return if $deja_vu++; 
    for my $i (0..7) {
      $bits[$i] = "";
      for my $j (0..7) {
	my $off = ($i - $j + 8) % 8;
	my $str = "";
	$str .= (int(($off + $_) / 4) & 1) for (0..7);
	$bits[$i] .=  pack("b8", $str);
      }
      $self->DefineBitmap(__PACKAGE__ . "::ma$i", 8, 8, $bits[$i]);
    }
  }
}

{
  my $cur_color;
  my $button_1_mode;
  my ($ax, $ay); # dragging anchor
  my ($amx, $amy, $aMx, $aMy); 
  
  sub convert {
    my ($c, $x, $y) = @_;
    my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$c->cget("-view")};
    
    my $cx = $min_x + floor($c->canvasx($x) / $cell_size);
    my $cy = $max_y - floor($c->canvasy($y) / $cell_size);

    "$cx,$cy";
  }
  
  sub handle_1_click {
    my $c = shift;
    my $e = $c->XEvent;

    my($x, $y) = ($e->x, $e->y);

	if ($c->is_selected($x, $y)) {
	  ($ax, $ay) = ($x, $y);
	  ($amx, $amy, $aMx, $aMy) = @{$c->{sel}{coords}};
	  $button_1_mode = \&handle_1_drag_move;	  
	}
	else {
	  $c->sel_deactivate();
	  $button_1_mode = \&handle_1_drag_draw; 
	}

    my $p = convert($c, $x, $y);
    $cur_color = $c->itemcget($c->{cell}{$p}, "-fill") 
      eq "white" ? "black" : "white";
    handle_1_drag($c, @_);

    if (!$c->{dirty}) {
      $c->{dirty} = 1;
      $c->Callback("-dirty");
    }
  }
  
  sub handle_1_drag {
	$button_1_mode->(@_);
  }

  sub handle_1_drag_draw {
	my $c = shift;
	my $e = $c->XEvent;
	my ($x, $y) = ($e->x, $e->y);
	
	# Ick, I'll do scrolling stuff later.
    #
    #    if ($x < 0) { $c->xview(scroll => -1, "units") }
    #    if ($y < 0) { $c->yview(scroll => -1, "units") }
    my $p = convert($c, $x, $y);
    exists $c->{cell}{$p} or return;
    $c->itemconfigure($c->{cell}{$p}, -fill => $cur_color); 
    if ($cur_color eq "black") {
      $c->{pixel}{$p} = 1;
    } 
    else {
      delete $c->{pixel}{$p};
    }
  }

  sub handle_1_drag_move {
	my $c = shift;
	my $e = $c->XEvent;
	my ($x, $y) = ($e->x, $e->y);
	my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$c->cget("-view")};
	my ($dx, $dy) = (int(($x - $ax) / $cell_size),  int(($ay - $y) / $cell_size));
	$c->{sel}{coords} = [$amx + $dx, $amy + $dy, $aMx + $dx, $aMy + $dy];
	$c->redo_selection_pos(
						   -$min_x + $amx + $dx,     $max_y - $aMy - $dy,
						   -$min_x + $aMx + $dx + 1, $max_y - $amy - $dy + 1
						  );
	$c->redo_pixels();

	if (!$c->{dirty}) {
	  $c->{dirty} = 1;
	  $c->Callback("-dirty");
	}
  }

}

sub get_pixels {
  my $self = shift;

  if ($self->{sel}{active} && $self->{sel}{float}) {
	my $rv;
	$self->sel_unfloat();
	$rv = {%{$self->{pixel}}};
	$self->sel_float();
	return $rv;
  }
  else {
	$self->{pixel};
  }
}

sub set_pixels {
  my $self = shift;
  $self->sel_deactivate();
  ($self->{pixel}) = @_;
  $self->redo_pixels();
}

# dirtiness methods

sub undirty {
  my $self = shift;
  $self->{dirty} = 0;
}

sub is_dirty {
  my $self = shift;
  $self->{dirty};
}

# redrawing methods

sub redo_pixels {
  my $self = shift;
  $self->itemconfigure("cell", "-fill", "white");
  foreach my $p (keys %{$self->{pixel}}) {
    $self->itemconfigure($self->{cell}{$p}, "-fill", "black");
  }
  if ($self->{sel}{float}) {
	my ($x, $y);
    my ($mx, $my, $Mx, $My) = @{$self->{sel}{coords}};
    for $x ($mx..$Mx) {
      for $y ($my..$My) {
		$self->itemconfigure($self->{cell}{"$x,$y"},"-fill",
							 $self->{sel}{pixel}{($x-$mx).",".($y-$my)} ? "black" : "white");
	  }
	}
  }
}


sub redo_cell_coords {
  my $self = shift;
  my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};
  foreach (keys %{$self->{cell}}) {
    my ($x, $y) = split /,/;
    $self->coords(
		  $self->{cell}{$_}, 
		  ($x-$min_x) * $cell_size, 
		  ($max_y-$y) * $cell_size,
		  ($x-$min_x + 1) * $cell_size, 
		  ($max_y-$y + 1) * $cell_size, 
		 );
  }
}

sub redo_cells {
  my $self = shift;
  my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};
  my ($x, $y);

  $self->delete("cell");

  $self->{cell} = {};
  my $outline = $self->cget("-grid") ? "gray" : undef;

  for ($x = $min_x; $x <= $max_x; $x++) {
    for ($y = $min_y; $y <= $max_y; $y++) {
      $self->{cell}{"$x,$y"} = 
	$self->createRectangle
	  (
	   0, 0, 0, 0,
	   -fill => "white", 
	   -outline => $outline, 
	   -tags => ["cell"],
	  );
    }
  }
  $self->redo_pixels();
}

sub redo_canvas {
  my $self = shift;
  my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};
  
  $self->configure(-height => ($max_y - $min_y + 1) * $cell_size,
		   -width  => ($max_x - $min_x + 1) * $cell_size);
}

sub redo_axes {
  my $self = shift;
  my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};
  my ($width, $height) = (($max_x - $min_x + 1) * $cell_size, ($max_y - $min_y + 1) * $cell_size);
  if ($self->cget("-axes")) {
    $self->coords($self->{x_axis}, 
		   0, ($max_y+1) * $cell_size, 
		   $width, ($max_y+1) * $cell_size);
    # Debugging foo:
    # $main::cc = $self;
    $self->coords($self->{y_axis}, 
		  (-$min_x) * $cell_size, 0, 
		  (-$min_x) * $cell_size, $height);
    # axes uber alles!
    $self->raise($self->{x_axis}, "all");   
    $self->raise($self->{y_axis}, "all");   
  }
  else {
    $self->coords($self->{x_axis}, 0, 0, 0, 0);
    $self->coords($self->{y_axis}, 0, 0, 0, 0);
  }
}

sub redo_selection {
  my $self = shift;
  $self->{ma}=($self->{ma}+1)%8; 
  $self->itemconfigure($self->{sel}{fore}, -stipple => __PACKAGE__ . "::ma$self->{ma}");
  $self->{sel}{active} = $self->after(50, sub{$self->redo_selection});
}

sub redo_selection_pos {
 my $self = shift; 
 my ($x1c, $y1c, $x2c, $y2c) = @_;
 my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};

 $_ = $_ * $cell_size + 1 for ($x1c, $y1c);
 $_ = $_ * $cell_size - 1 for ($x2c, $y2c);

 # Make things look nicer if we have the grid turned off
 if (!$self->cget("-grid")) {
   for ($x1c, $y1c) { if ($_ != 1) { $_-- } }
 }

 for (qw(back fore)) {
   $self->coords($self->{sel}{$_}, $x1c, $y1c, $x2c, $y1c, $x2c, $y2c, $x1c, $y2c, $x1c, $y1c);
   $self->raise ($self->{sel}{$_}, "all");
 }
}

sub redo_current_selection_pos {
  my $self = shift;
  if ($self->{sel}{active}) {
	my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};
	my ($mx, $my, $Mx, $My) = @{$self->{sel}{coords}};
	$self->redo_selection_pos(
							  -$min_x + $mx,     $max_y - $My,
							  -$min_x + $Mx + 1, $max_y - $my + 1
							 );
  }
}

# selection methods 

{
  my ($x1, $y1, $x2, $y2);

  sub numeric {$a <=> $b}

  sub is_selected {
	my $self = shift;
	return 0 unless $self->{sel}{active};
	my ($x, $y) = @_;
    my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};
	my ($mx, $my, $Mx, $My) = @{$self->{sel}{coords}};
	my $cx = $min_x + floor($self->canvasx($x) / $cell_size);
    my $cy = $max_y - floor($self->canvasy($y) / $cell_size);
	$cx < $mx and return 0;
	$cx > $Mx and return 0;
	$cy < $my and return 0;
	$cy > $My and return 0;
	return 1;
  }

  sub handle_2_click {
    my $self = shift;
	$self->sel_x_paste();
  }

  sub handle_3_click {
    my $self = shift;
    ($x1, $y1) = ($Tk::event->x, $Tk::event->y);
    $self->sel_deactivate();
  }

  sub handle_3_drag {
    my $self = shift;
    my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};
    ($x2, $y2) = ($Tk::event->x, $Tk::event->y);
    my ($x1c, $x2c) = sort numeric ($x1, $x2);
    my ($y1c, $y2c) = sort numeric ($y1, $y2);
    for ($x1c, $y1c) {
      $_ = floor($_ / $cell_size);
      $_ < 0 and $_ = 0;
    }
    for ($x2c, $y2c) {
      $_ = ceil($_ / $cell_size);
    }
    $x2c > $max_x - $min_x + 1 and $x2c = $max_x - $min_x + 1;
    $y2c > $max_y - $min_y + 1 and $y2c = $max_y - $min_y + 1;
    $self->{sel}{coords} = [$x1c+$min_x, $max_y-$y2c+1, $x2c+$min_x-1, $max_y-$y1c];
	$self->redo_selection_pos($x1c, $y1c, $x2c, $y2c);  
    $self->sel_activate();
  }

  sub handle_3_release {
    my $self = shift;
	if ($self->{sel}{active}) {
	  $self->sel_float();
	}
  }

  # This erases the bitmap underlying the selection
  # and sticks the pixels that were there in
  # a floating selection buffer.
  sub sel_float {
    my $self = shift;
	my ($x, $y);
    my ($mx, $my, $Mx, $My) = @{$self->{sel}{coords}};
    for $x ($mx..$Mx) {
      for $y ($my..$My) {
		if (delete $self->{pixel}{"$x,$y"}) {
		  $self->{sel}{pixel}{($x-$mx).",".($y-$my)} = 1;
		}
      }
    }
    # Just screwing around with the X selection here...
	{
	  my $string = join(";", @{$self->{sel}{coords}}) . "\n" . join(";", %{$self->{sel}{pixel}}); 
	  $self->SelectionOwn();
	  $self->SelectionHandle(sub{$string});
	}

	$self->{sel}{float} = 1;
    $self->redo_pixels();
  }
  
  # Reverse of the above, more or less
  sub sel_unfloat {
	my $self = shift;

	if (defined $self->{sel}{float}) {
	  undef $self->{sel}{float};	
	  my ($x, $y);
	  my ($mx, $my, $Mx, $My) = @{$self->{sel}{coords}};
	  for $x ($mx..$Mx) {
		for $y ($my..$My) {
		  if ($self->{sel}{pixel}{($x-$mx).",".($y-$my)}) {
			$self->{pixel}{"$x,$y"} = 1;
		  }
		  else {
			delete $self->{pixel}{"$x,$y"};
		  }
		}
	  }
	  undef $self->{sel}{pixel};
	}
  }
  
  sub sel_deactivate {
    my $self = shift;
    if (defined $self->{sel}{active}) {
	  for (qw(back fore)) {
		$self->coords($self->{sel}{$_}, 0, 0, 0, 0);
	  }
      $self->afterCancel($self->{sel}{active});
	  $self->sel_unfloat();
      undef $self->{sel}{active};
    }
  }
  
  sub sel_activate {
    my $self = shift;
    unless (defined $self->{sel}{active}) {
      $self->{sel}{active} = $self->after(50, sub{$self->redo_selection});
    }
  }

  sub sel_clear {
	my $self = shift;
	if ($self->{sel}{active}) {
	  $self->{sel}{pixel} = {};
	  $self->sel_deactivate();
	}
	else {
	  $self->{pixel} = {};
	}
	$self->redo_pixels();

	if (!$self->{dirty}) {
	  $self->{dirty} = 1;
	  $self->Callback("-dirty");
	}
  }

  sub sel_copy {
	my $self = shift;
	
	if ($self->{sel}{active}) {	
	  $clipboard->{pixel} = { %{$self->{sel}{pixel}} };
	  $clipboard->{coords} = [ @{$self->{sel}{coords}} ];
	}
	else {
	  my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};
	  $clipboard->{pixel} = {};
	  for $x ($min_x..$max_x) {
		for $y ($min_y..$max_y) {
		  if ($self->{pixel}{"$x,$y"}) {
			$clipboard->{pixel}{($x-$min_x).",".($y-$min_y)} = 1;
		  }
		}
	  }
	  $clipboard->{coords} = [$min_x, $min_y, $max_x, $max_y];
	}
  }
  
  sub sel_cut {
	my $self = shift;
	$self->sel_copy();
	$self->sel_clear();
  }

  sub sel_paste {
	my $self = shift;  
	my ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$self->cget("-view")};

	return unless defined $clipboard;

	$self->sel_deactivate();
	$self->sel_activate();
	$self->{sel}{float} = 1;
	$self->{sel}{pixel} = { %{$clipboard->{pixel}} };
	$self->{sel}{coords} = [ @{$clipboard->{coords}} ];
	$self->redo_current_selection_pos();
	$self->redo_pixels();

	if (!$self->{dirty}) {
	  $self->{dirty} = 1;
	  $self->Callback("-dirty");
	}
  }

  sub sel_x_paste {
	my $self = shift;  

	my $xsel = $self->SelectionGet();

	return unless $xsel =~ /;/;

	my ($coords, $pixel) = split /\n/, $xsel;
	my @coords = split ";", $coords;
	my %pixel = split ";", $pixel;

	$self->sel_deactivate();
	$self->sel_activate();
	$self->{sel}{float} = 1;
	$self->{sel}{pixel} = { %pixel };
	$self->{sel}{coords} = [ @coords ];
	$self->redo_current_selection_pos();
	$self->redo_pixels();

	if (!$self->{dirty}) {
	  $self->{dirty} = 1;
	  $self->Callback("-dirty");
	}
  }

  sub sel_invert {
	my $self = shift;
	$self->sel_transform(sub{
						   my ($pixel, $x, $y, $X, $Y) = @_;
						   !$pixel->{"$x,$y"}
						 }); 
  }

  sub sel_flip_horizontal {
	my $self = shift;
	$self->sel_transform(sub{
						   my ($pixel, $x, $y, $X, $Y) = @_;
						   $pixel->{($X - $x) . ",$y"}
						 }); 
  }

  sub sel_flip_vertical {
	my $self = shift;
	$self->sel_transform(sub{
						   my ($pixel, $x, $y, $X, $Y) = @_;
						   $pixel->{"$x," . ($Y - $y)}
						 }); 
  }
				

  sub sel_transform {
	my $self = shift;
	my ($test) = @_;
	if ($self->{sel}{active}) {
	  my $newpixel = {};
	  my ($mx, $my, $Mx, $My) = @{$self->{sel}{coords}};
	  for my $x (0..$Mx-$mx) {
		for my $y (0..$My-$my) {
		  if ($test->($self->{sel}{pixel}, $x, $y, $Mx - $mx, $My - $my)) { 
			$newpixel->{"$x,$y"} = 1;
		  }
		}
	  }
	  $self->{sel}{pixel} = $newpixel;
	    
	  $self->redo_pixels();
	  
	  if (!$self->{dirty}) {
		$self->{dirty} = 1;
		$self->Callback("-dirty");
	  }
	}
  }
}

# ConfigSpecs methods

sub view {
  my $self = shift;
  return $self->{Configure}{-view} unless @_;
  my ($view) = @_;
  $self->{Configure}{-view} = [@$view];
  $self->redo_cells;
  $self->redo_cell_coords;
  $self->redo_canvas;
  $self->redo_axes;
  $self->redo_current_selection_pos;
}

sub axes {
  my $self = shift;
  return $self->{Configure}{-axes} unless @_;
  my ($axes) = @_;
  $self->{Configure}{-axes} = $axes;
  $self->redo_axes;
}

sub axes_color {
  my $self = shift;
  return $self->{Configure}{-axes_color} unless @_;
  my ($axes_color) = @_;
  $self->{Configure}{-axes_color} = $axes_color;
  $self->itemconfigure($self->{x_axis}, fill => $axes_color);
  $self->itemconfigure($self->{y_axis}, fill => $axes_color);
}

sub grid {
  my $self = shift;
  return $self->{Configure}{-grid} unless @_;
  my ($grid) = @_;
  $self->{Configure}{-grid} = $grid;
  my $outline = $self->cget("-grid") ? "gray" : undef;
  $self->itemconfigure("cell", -outline => $outline);

  # Make the selection look right if we have one
  $self->redo_current_selection_pos;
}


###############################
# Character Editor Widget

# A bitmap editor with a bit
# of frosting around it, and hooks
# into a Font::BDF object.

package Tk::CharEdit;

use base qw(Tk::Toplevel);

Construct Tk::Widget "CharEdit";

sub ClassInit {
  my ($class, $mw) = @_;
  $class->SUPER::ClassInit($mw);
}


sub Populate {
  my ($w, $args) = @_; 
  my $font = delete $args->{-font};

  # XXX: probably should fail, actually
  $font = Font::BDF->new unless defined $font;

  my $cur_char = delete $args->{-char};
  $cur_char = (ord 'a') unless defined $cur_char;
  @$w{qw(font cur_char)} = ($font, $cur_char);

  # Create bitmap editor, but don't pack it yet.
  # We need it for menu stuff, but the menus should
  # get packed first.
  my $bme = $w->BitmapEdit(-dirty => sub { $w->dirty(1) });

  my $menubar = $w->Frame
    (
     -relief => 'raised', -borderwidth => 2
    )->pack(-side => "top", -fill => "x");
    
  my $character_menubutton = $menubar->Menubutton
    (
     -text => "Character",  -underline => 0, -menuitems =>
     [
      [Button => '~Info...', -accelerator => "i", -command => sub { $w->menu_info } ], 
      [Separator => ''],
      [Button => '~Prev', -accelerator => "p", -command => sub { $w->menu_prev } ],
      [Button => '~Next', -accelerator => "n", -command => sub { $w->menu_next } ],
      [Separator => ''],
      [Button => '~Update', -accelerator => "u", -command => sub { $w->menu_update } ], 
      [Separator => ''],
      [Button => '~Close', -accelerator => "w", -command => sub { $w->destroy } ],
     ]
    )->pack(-side => "left");
  my $character_menu = $character_menubutton->cget("-menu");
  $w->Advertise(character_menu => $character_menu);

  # Ugh, this is terrible, and will break if 
  # tear-off menus are disabled.
  $w->bind("<Key-i>", sub {$character_menu->invoke("Info...")});
  $w->bind("<Key-p>", sub {$character_menu->invoke("Prev")});
  $w->bind("<Key-n>", sub {$character_menu->invoke("Next")});
  $w->bind("<Key-u>", sub {$character_menu->invoke("Update")});
  $w->bind("<Key-w>", sub {$character_menu->invoke("Close")});

  my ($grid, $axes) = ($bme->cget("-grid"), $bme->cget("-axes"));

  my $enc_format;
  my $menu_enc_format = sub {$w->configure(-enc_format => $enc_format)};

  my $literal = sub{($_[0]<32||$_[0]>126)?"\\x".sprintf("%x",$_[0]):chr $_[0]};
  my $decimal = sub{$_[0]};
  my $octal = sub{sprintf("0%o",$_[0])};
  my $hex = sub{sprintf("0x%x",$_[0])};
  $enc_format = $literal;

  my $update_ask = sub 
    {
      $w->messageBox
	(
	 -type => "OKCancel",
	 -icon => "warning",
	 -message => "Changing character without updating. Update now?"
	) 
	  eq "Ok";
    };
  $w->{update_mode} = $update_ask;

  my $edit_menubutton = $menubar->Menubutton
	(
	 qw/-text Edit -underline 0 -menuitems/ =>
	 [
	  [Button => 'Copy', -accelerator => "C-c", -command => sub {$bme->sel_copy()} ],
	  [Button => 'Cut', -accelerator => "C-x", -command => sub {$bme->sel_cut()} ],
	  [Button => 'Paste', -accelerator => "C-v", -command => sub {$bme->sel_paste()} ],
	  [Button => 'Clear', -accelerator => "Delete", -command => sub {$bme->sel_clear()} ],
	  [Separator => ''],
	  [Button => 'Invert', -accelerator => "C-i", -command => sub {$bme->sel_invert()} ],
	  [Button => 'Flip Vertical', -accelerator => "C-f", -command => sub {$bme->sel_flip_vertical()} ],
	  [Button => 'Flip Horizontal', -accelerator => "C-h", -command => sub {$bme->sel_flip_horizontal()} ],
	 ],
	)->pack(-side => "left");
  my $edit_menu = $edit_menubutton->cget("-menu");

  $w->bind("<Control-c>", sub {$edit_menu->invoke("Copy")});
  $w->bind("<Control-x>", sub {$edit_menu->invoke("Cut")});
  $w->bind("<Control-v>", sub {$edit_menu->invoke("Paste")});
  $w->bind("<BackSpace>", sub {$edit_menu->invoke("Clear")});
  $w->bind("<Delete>", sub {$edit_menu->invoke("Clear")});
  $w->bind("<Control-i>", sub {$edit_menu->invoke("Invert")});
  $w->bind("<Control-f>", sub {$edit_menu->invoke("Flip Vertical")});
  $w->bind("<Control-h>", sub {$edit_menu->invoke("Flip Horizontal")});

  my $options_menubutton = $menubar->Menubutton
    (
     qw/-text Options -underline 0 -menuitems/ =>
     [
      [Button => '~View...', -accelerator => "v", -command => sub { $w->menu_view } ],
      [Checkbutton => '~Grid', -accelerator => "g", -variable => \$grid, 
       -command => sub {$bme->configure(-grid => $grid)} ],
      [Checkbutton => '~Axes', -accelerator => "a", -variable => \$axes, 
       -command => sub {$bme->configure(-axes => $axes)} ],
      [Cascade => "Encoding Format", -underline => 0, -menuitems =>
       [
	[Radiobutton => "Literal", -value => $literal, 
	 -variable => \$enc_format, -command => $menu_enc_format],
	[Radiobutton => "Decimal", -value => $decimal, 
	 -variable => \$enc_format, -command => $menu_enc_format],
	[Radiobutton => "Octal", -value => $octal, 
	 -variable => \$enc_format, -command => $menu_enc_format],
	[Radiobutton => "Hexadecimal", -value => $hex, 
	 -variable => \$enc_format, -command => $menu_enc_format],
       ]
      ],
      [Cascade => "Update Mode", -underline => 0, -menuitems =>
       [
	[Radiobutton => "Always autoupdate", -value => sub { 1 }, 
	 -variable => \$w->{update_mode}],
	[Radiobutton => "Ask to update", -value => $update_ask, 
	 -variable => \$w->{update_mode}],
	[Radiobutton => "Never autoupdate", -value => sub { 0 }, 
	 -variable => \$w->{update_mode}],
       ]
      ]
     ]
    )->pack(-side => "left");
  my $options_menu = $options_menubutton->cget("-menu");

  $w->bind("<Key-v>", sub {$options_menu->invoke("View...")});
  $w->bind("<Key-g>", sub {$options_menu->invoke("Grid")});
  $w->bind("<Key-a>", sub {$options_menu->invoke("Axes")});

  my $statusbar = $w->Frame
    (
     -relief => 'raised', 
     -borderwidth => 2
    )->pack(-fill => "x", -side => "bottom");
  my $dirty_status = $statusbar->Label()->pack(-side => "left");
  my $char_status = $statusbar->Label()->pack(-side => "left");
  $w->Advertise(dirty_status => $dirty_status);
  $w->Advertise(char_status => $char_status);

  # Finally deal with the rest of the bitmap editor
  $bme->pack();
  $w->Advertise(bitmap => $bme);

  $w->ConfigSpecs
    (
     -update_hook => ["CALLBACK", undef, undef, undef],
     -enc_format =>  ["METHOD",   undef, undef, $literal],
     -view =>        [$bme,       undef, undef, undef],
    );

  $w->Delegates
    (
     get_pixels => "bitmap",
     set_pixels => "bitmap",
     is_dirty => "bitmap",
    );
  $w->load_char();
  $w->SUPER::Populate($args);
}

sub load_char {
  my $self = shift;
  $self->set_pixels($self->{font}->get_pixels($self->{cur_char}));
  $self->dirty(0);
}

#sub save_char {
#  my $self = shift;
#  # my $bme = $self->Subwidget("bitmap");

#  $self->{font}->set_pixels($self->{cur_char}, $self->get_pixels());
#}

sub go_to_char {
  my $self = shift;

#  $self->save_char;
  ($self->{cur_char}) = @_;
  $self->load_char;
  $self->update_statusbar;
}

sub menu_next {
  my $self = shift;

  if ($self->is_dirty && $self->{update_mode}->()) {
    $self->menu_update();
  }
  $self->go_to_char($self->{cur_char} + 1);
}

sub menu_prev {
  my $self = shift;
  
  if ($self->is_dirty && $self->{update_mode}->()) {
    $self->menu_update();
  }
  $self->go_to_char($self->{cur_char} - 1);
}

sub menu_update {
  my $self = shift;
  $self->Callback(-update_hook => $self, $self->{cur_char});
  $self->dirty(0);
}

sub menu_view {
  my $self = shift;
  my $bme = $self->Subwidget("bitmap");
  my $tl = $self->Toplevel();
  my ($cell_size, $min_x, $min_y, $max_x, $max_y);
  my $f = $tl->Frame()->pack(-side => "bottom");
  $f->Button(-text => "Ok", -command => sub {
	       $bme->configure(-view => [$cell_size, $min_x, $min_y, $max_x, $max_y]);
	       $tl->destroy();
	     })->pack(-side => "left");
  $f->Button(-text => "Apply", -command => sub {
	       $bme->configure(-view => [$cell_size, $min_x, $min_y, $max_x, $max_y]);
	     })->pack(-side => "left");
  $f->Button(-text => "Cancel", -command => sub{$tl->destroy})->pack(-side => "left");
  $tl->LabEntry(-label => "Cell size", -textvariable => \$cell_size)->pack();
  $tl->LabEntry(-label => "Min x", -textvariable => \$min_x)->pack();
  $tl->LabEntry(-label => "Min y", -textvariable => \$min_y)->pack();
  $tl->LabEntry(-label => "Max x", -textvariable => \$max_x)->pack();
  $tl->LabEntry(-label => "Max y", -textvariable => \$max_y)->pack();
  ($cell_size, $min_x, $min_y, $max_x, $max_y) = @{$bme->cget("-view")};
}

sub menu_grid {
  my $cb = shift;
  my ($w) = @_;
  my $bme = $w->Subwidget("bitmap");
  $bme->configure(-grid => $cb->cget("-value"));
}

sub menu_axes {
  my $cb = shift;
  my ($w) = @_;
  my $bme = $w->Subwidget("bitmap");
  $bme->configure(-axes => $cb->cget("-value"));
}

sub menu_info {
  my $self = shift;
  my $bme = $self->Subwidget("bitmap");
  my $tl = $self->Toplevel();
  my ($name, $DWIDTH, $SWIDTH, $dw);
  
  my $f = $tl->Frame()->pack(-side => "bottom");
  $f->Button(-text => "Ok", -command => sub {
	       $self->{font}->set_char_info($self->{cur_char}, $name, [$dw, 0], $SWIDTH);
	       $tl->destroy();
	     })->pack(-side => "left");
  $f->Button(-text => "Cancel", -command => sub{$tl->destroy})->pack(-side => "left");
  $tl->LabEntry(-label => "Name", -textvariable => \$name)->pack();
  $tl->LabEntry(-label => "Pixel Width", -textvariable => \$dw)->pack();
  ($name, $DWIDTH, $SWIDTH) = $self->{font}->get_char_info($self->{cur_char});
  $dw = $DWIDTH->[0];
}

sub enc_format {
  my $self = shift;
  return $self->{Configure}{-enc_format} unless @_;
  my ($enc_format) = @_;
  $self->{Configure}{-enc_format} = $enc_format;
  $self->update_statusbar;
}

sub update_statusbar {
  my $self = shift;
  my $enc_format = $self->cget("-enc_format");
  $self->Subwidget("dirty_status")->configure
    (
     # Idunno, sometimes I dream in emacs...
     -text => $self->is_dirty ? "** " : "-- ",
	 -font => "fixed",
    ); 
  if (ref $enc_format eq "CODE") {
    $self->Subwidget("char_status")->configure
      (
       -text => &$enc_format($self->{cur_char})
      );
  }
}

sub dirty {
  my $self = shift;
  my ($dirty) = @_;
  my $character_menu = $self->Subwidget("character_menu");
  my $bme = $self->Subwidget("bitmap");
  if ($dirty) {
    $character_menu->entryconfigure("Update", -state => "normal");
  }
  else {
    $character_menu->entryconfigure("Update", -state => "disabled");
    $bme->undirty;
  }
  $self->update_statusbar;
}

###############################
# Main program

package main;

# Ugh, these should not be here.
# I *should* be doing dynamic resizing stuff,
# but I'm too lazy right now.
$CELL_HEIGHT = 25;
$CELL_WIDTH = 50;

# Display low ascii page
$page_offset = 0;

# Standard XLFD property names
@XLFD_names = qw
  (
   FOUNDRY
   FAMILY_NAME 
   WEIGHT_NAME
   SLANT
   SETWIDTH_NAME
   ADD_STYLE_NAME
   PIXEL_SIZE
   POINT_SIZE
   RESOLUTION_X
   RESOLUTION_Y
   SPACING
   AVERAGE_WIDTH
   CHARSET_REGISTRY
   CHARSET_ENCODING
  );

# Default values for XLFD properties
#
# Some of these don't make a *lot*
# of sense without knowing something 
# about the font (average width, point/
# pixel size, spacing, etc.)
# Maybe I should be calculating these
# from font data...

@XLFD_default{@XLFD_names} = 
  (
   "misc",
   "",
   "Medium",
   "R",
   "Normal",
   "",
   10,
   100,
   75,
   75,
   "M",
   70,
   "ISO8859",
   1,
  );

$mw = MainWindow->new();
tie $sticky_filename, "TitleScalar", $mw, "Ptkfonted: ", "Ptkfonted";

$menubar = $mw->Frame
  (
   -relief => 'raised', -borderwidth => 2
  )->pack(-side => "top", -fill => "x");
  
my $file_menubutton = $menubar->Menubutton
  (
   qw/-text File -underline 0 -menuitems/ =>
   [
    [Button => '~New', -command => \&menu_file_new ],
    [Button => '~Open...', -command => \&menu_file_open ],
    [Button => 'Open From Font Server...', -command => \&menu_file_open_from_font_server ],
    [Separator => ''],
    [Button => '~Save', -command => \&menu_file_save ],
    [Button => 'Save ~As...', -command => \&menu_file_save_as ],
    [Separator => ''],
    [Button => '~Quit', -command => \&menu_file_quit ],
   ]
  )->pack(-side => "left");
my $file_menu = $file_menubutton->cget("-menu");

$menubar->Menubutton
  (
   qw/-text Font -underline 0 -menuitems/ =>
   [
    [Button => '~Info...', -command => \&menu_font_info ],
    [Button => '~Properties...', -command => \&menu_font_properties ],
    [Separator => ''],
    [Button => 'Global Set ~Width...', -command => \&menu_font_global_set_width],
    [Separator => ''],
    [Button => 'Pre~view...', -command => \&menu_font_preview],
   ]
  )->pack(-side => "left");

my $enc_format;
my $menu_enc_format = sub {
  foreach (0..$#labels) {
    $c->itemconfigure($labels[$_], -text => &$enc_format($_ + $page_offset));
  }
};

my $literal = sub{($_[0]<32||$_[0]>126)?"\\x".sprintf("%x",$_[0]):chr $_[0]};
my $decimal = sub{$_[0]};
my $octal = sub{sprintf("0%o",$_[0])};
my $hex = sub{sprintf("0x%x",$_[0])};
$enc_format = $literal;

$menubar->Menubutton
  (
   qw/-text Options -underline 0 -menuitems/ =>
   [
    [Button => 'Default ~View...', -command => \&menu_options_default_view],
    [Cascade => '~Encoding Format', -menuitems => 
     [
      [Radiobutton => "Literal", -value => $literal, 
       -variable => \$enc_format, -command => $menu_enc_format],
      [Radiobutton => "Decimal", -value => $decimal, 
       -variable => \$enc_format, -command => $menu_enc_format],
      [Radiobutton => "Octal", -value => $octal, 
       -variable => \$enc_format, -command => $menu_enc_format],
      [Radiobutton => "Hexadecimal", -value => $hex, 
       -variable => \$enc_format, -command => $menu_enc_format],
     ]
    ],
   ]
  )->pack(-side => "left");

$menubar->Menubutton
  (
   qw/-text Help -underline 0 -menuitems/ =>
   [
    [Button => '~Documentation...', -command => \&menu_help_documentation ],
    [Separator => ''],
    [Button => '~About...', -command => \&menu_help_about ],
   ]
  )->pack(-side => "right");

$c = $mw->Canvas(-width => 16 * $CELL_WIDTH, -height => 16 * $CELL_HEIGHT)->pack();

for ($y = 0; $y < 8; $y++) {
  for ($x = 0; $x < 16; $x++) {
    my $char = $y * 16 + $x;
    $c->createRectangle(
			$x * $CELL_WIDTH ,
			2 * $y * $CELL_HEIGHT, 
			($x + 1) * $CELL_WIDTH ,
			2 * ($y + 1) * $CELL_HEIGHT, 
			-tags => ["c$char"], -fill => "white");
    $locx = ($x + 1/2) * $CELL_WIDTH;
    $locy = (2 * $y + 1/2) * $CELL_HEIGHT;
	my $canvas_font = $c->optionGet("font", "Font");
    $labels[$char] = $c->createText($locx, $locy, 
									-anchor => "c", -text => &$enc_format($char), 
									($canvas_font ? (-font => $canvas_font) : ()), 
									-fill => "#3f3f7f", # XXX: ack, should be configurable.
									-tags => ["c$char"]);
    $images{$char} = $c->createImage($locx, $locy + $CELL_HEIGHT, 
									 -anchor => "c", -image => undef, 
									 -tags => ["c$char"]);
    $c->bind("c$char", "<1>", sub { new_char_edit($char + $page_offset) } );
  }
}

$mw->Button(-text => "Prev", -command => sub {
			  $page_offset -= 128;
			  $page_offset < 0 and $page_offset = 0;
			  for (0..127) {
				$c->itemconfigure($labels[$_], -text => &$enc_format($_ + $page_offset));
			  }
			  update_images();
			})->pack(-side => "left");
$mw->Button(-text => "Next", -command => sub {
			  $page_offset += 128;
			  for (0..127) {
				$c->itemconfigure($labels[$_], -text => &$enc_format($_ + $page_offset));
			  }
			  update_images();
			})->pack(-side => "left");

$default_view = [16, 0, -5, 7, 11];

if (@ARGV) 
  { menu_file_open(shift) }
else
  { $font = Font::BDF->new() }

dirty(0);

MainLoop();

sub menu_file_new {
  if ($dirty) {
    my $res = $mw->messageBox(-icon => "warning",
			      -type => "OKCancel",
			      -message => "Some work unsaved. Discard font anyway?");
    return unless $res eq "Ok";
    
  }
  foreach (keys %images) {
    $c->itemconfigure($images{$_}, -image => undef);
  }
  $font = Font::BDF->new();
  undef $sticky_filename;
}

sub update_images {
  foreach (keys %images) {
    $c->itemconfigure($images{$_}, -image => undef);
  }
  foreach ($font->encoded_chars) {
    my $pos = $_ - $page_offset;
    if (exists $images{$pos}) {
      my $data = $font->get_xbm($_);
      my $image = defined $data ? $mw->Bitmap(-data => $data) : undef;
      $c->itemconfigure($images{$pos}, -image => $image);
    }
  }
}

sub menu_file_open {
  my ($filename) = @_;

  if (defined $filename) { # should only happen at commandline-processing time
    unless (open(IN, $filename)) {
      die "Could not open $filename: ($!)";
    }
  }
  else {
    if ($dirty) {
      my $res = $mw->messageBox(-icon => "warning",
				-type => "OKCancel",
				-message => "Some work unsaved. Open new font anyway?");
      return unless $res eq "Ok";
    }
    $filename = $mw->getOpenFile();
    return unless defined $filename;
    unless (open(IN, $filename)) {
      $mw->messageBox(-icon => "error", 
		      -type => "OK", 
		      -message => "Error reading $filename: $!");
      return;
    }
  }
  $font = Font::BDF->new_from_bdf(IN);
  update_images();
  @{$default_view}[1..4] = expand_view(@{$default_view}[1..4]);
  $sticky_filename = $filename;
  dirty(0);
  close(IN);
}

sub menu_file_open_from_font_server {
  if ($dirty) {
	my $res = $mw->messageBox(-icon => "warning",
							  -type => "OKCancel",
							  -message => "Some work unsaved. Open new font anyway?");
	return unless $res eq "Ok";
  }
  my $tl = $mw->Toplevel(-title => "Open...");
  my ($port, $font_name);
  $tl->LabEntry(-label => "Port", -textvariable => \$port)->pack();
  $tl->LabEntry(-label => "Font", -textvariable => \$font_name)->pack();
  $tl->Button(-text => "Ok", -command => sub {$ok = 1})->pack(-side => "left");
  $tl->Button(-text => "Cancel", -command => sub {$ok = undef;} )->pack(-side => "left");
  $port = 7100;
  $font_name = "fixed";
  $tl->waitVariable(\$ok);
  $tl->destroy();
  if ($ok) {
	my $filename = "/tmp/tmp$$.bdf";
	system "fstobdf -s unix/:$port -fn '$font_name' >$filename";
	open IN, $filename or die $!;
	$font = Font::BDF->new_from_bdf(IN);
	update_images();
	@{$default_view}[1..4] = expand_view(@{$default_view}[1..4]);
	$sticky_filename = "";
	dirty(0);
	close(IN);
	unlink $filename;
  }
}

sub expand_view {
  my (@old_view) = @_;
  foreach ($font->encoded_chars) {
    my (undef, undef, undef, $BBX) = $font->get_char_info($_);
    my ($min_x, $min_y, $max_x, $max_y) = 
      ($BBX->[2], $BBX->[3], $BBX->[0] + $BBX->[2] - 1, $BBX->[1] + $BBX->[3] - 1);
    $min_x < $old_view[0] and $old_view[0] = $min_x;
    $min_y < $old_view[1] and $old_view[1] = $min_y;
    $max_x > $old_view[2] and $old_view[2] = $max_x;
    $max_y > $old_view[3] and $old_view[3] = $max_y;
  }
  @old_view;
}

sub menu_file_save {
  my $filename = $sticky_filename;

  unless (open(OUT, ">$filename")) {
    $mw->messageBox(-icon => "error", 
		    -type => "OK", 
		    -message => "Error writing $filename: $!");
    return;
  }
  print OUT $font->bdf;
  close(OUT);
  dirty(0);
}

sub menu_file_save_as {
  my $filename = $mw->getSaveFile();
  if ($filename) {
    unless (open(OUT, ">$filename")) {
      $mw->messageBox(-icon => "error", 
		      -type => "OK", 
		      -message => "Error writing $filename: $!");
      return;
    }
    print OUT $font->bdf;
    close(OUT);
    $sticky_filename = $filename;
    dirty(0);
  }
}

sub menu_file_quit {
  if ($dirty) {
    my $res = $mw->messageBox(-icon => "warning",
			      -type => "OKCancel",
			      -message => "Some work unsaved. Quit anyway?");
    return unless $res eq "Ok";
  }
  exit(0);
}

sub menu_font_info {
  my $tl = $mw->Toplevel();
  my ($name, $pt_size, $x_resolution, $y_resolution);
  my $f = $tl->Frame()->pack(-side => "bottom");
  $f->Button(-text => "Ok", -command => sub {
	       $font->set_info($name, $pt_size, $x_resolution, $y_resolution);
	       dirty(1);
	       $tl->destroy();
	     })->pack(-side => "left");
  $f->Button(-text => "Cancel", -command => sub{$tl->destroy})->pack(-side => "left");
  my $f2 = $tl->Frame()->pack(-side => "bottom");
  $f2->Button(-text => "XLFD Name", -command => sub {
	       my %props = $font->get_properties;
	       $name = join "", map {"-$props{$_}"} @XLFD_names;
	     }
	    )->pack(-side => "left");
  $tl->LabEntry(-label => "Font name", -textvariable => \$name)->pack(-fill => "x");
  $tl->LabEntry(-label => "Point size", -textvariable => \$pt_size)->pack(-fill => "x");
  $tl->LabEntry(-label => "X-Resolution", -textvariable => \$x_resolution)->pack(-fill => "x");
  $tl->LabEntry(-label => "Y-Resolution", -textvariable => \$y_resolution)->pack(-fill => "x");
  ($name, $pt_size, $x_resolution, $y_resolution) = $font->get_info();
}

sub add_property_dialog {
  my $query = $mw->Toplevel(-title => "Add Property:");
  my ($key, $value, $ok);
  $query->LabEntry(-label => "Property Name:", -textvariable => \$key)->pack();
  $query->LabEntry(-label => "Property Value:", -textvariable => \$value)->pack();
  $query->Button(-text => "Ok", -command => sub {$ok = 1})->pack(-side => "left");
  $query->Button(-text => "Cancel", -command => sub {$ok = undef;} )->pack(-side => "left");
  ($key, $value) = @_;
  $query->waitVariable(\$ok);
  $query->destroy();
  return unless $ok;
  return ($key, $value);
}

sub add_property_entry {
  my ($lb, $propsref, $key, $valueref) = @_;
  my $label_font = $lb->optionGet("font", "Font");
  my $e = $lb->addchild("");
  $lb->itemCreate($e, 0, -itemtype => "text", -text => $key, -style => $lb->ItemStyle("text", -anchor => "e", $label_font ? (-font => $label_font) : ()));
  $lb->itemCreate($e, 1, -itemtype => "window", -widget => $lb->Entry(-textvariable => $valueref, -width => 40));
  $propsref->{$e} = [$key, $valueref];
}

sub menu_font_properties {
  my $tl = $mw->Toplevel(-title => "Properties");
  my %props = $font->get_properties;
  my %properties;
  my $lb = $tl->Scrolled("HList", -scrollbars => "osoe", -columns => 2, -selectmode => "multiple"); # multiple extended
  for (keys %props) { my $a = $props{$_}; add_property_entry($lb, \%properties, $_, \$a) } 
  my $f = $tl->Frame()->pack(-side => "bottom");
  $f->Button(-text => "Ok", -command => sub {
			   $font->set_properties( map {$properties{$_}[0], ${$properties{$_}[1]}} keys %properties );
			   dirty(1);
			   $tl->destroy();
			 })->pack(-side => "left");
  $f->Button(-text => "Cancel", -command => sub{$tl->destroy})->pack(-side => "left");
  
  $f = $tl->Frame()->pack(-side => "bottom");
  $f->Button(-text => "Add", -command => sub {
			   my ($key, $value) = add_property_dialog();
			   if ($key) {
				 add_property_entry($lb, \%properties, $key, \$value);
			   }
			 }
			)->pack(-side => "left");
  $f->Button(-text => "Add XLFD", -command => sub {
			   my %already_have = map {$properties{$_}[0], 1} keys %properties; 
			   foreach(keys %XLFD_default) {
				 unless ($already_have{$_}) {
				   my $value = $XLFD_default{$_};
				   add_property_entry($lb, \%properties, $_, \$value);
				 }
			   }
			 }
			)->pack(-side => "left");
  $f->Button(-text => "Delete", -command => sub {
			   my (@which) = $lb->info("selection");
			   for my $which (@which) {
				 $lb->delete("entry", $which);
				 delete $properties{$which};
			   }
			 }
			)->pack(-side => "left");
  $lb->pack(-side => "left", -expand => "yes", -fill => "both");  
}

sub menu_font_global_set_width {
 my $tl = $mw->Toplevel();
  my ($dw);
  my $f = $tl->Frame()->pack(-side => "bottom");
  $f->Button(-text => "Ok", -command => sub {
	       foreach ($font->encoded_chars) {
		 my ($name, $SWIDTH);
		 ($name, undef, $SWIDTH) = $font->get_char_info($_);
		 $font->set_char_info($_, $name, [$dw, 0], $SWIDTH);
	       }
	       $tl->destroy();
               dirty(1);
	     })->pack(-side => "left");
  $f->Button(-text => "Cancel", -command => sub{$tl->destroy})->pack(-side => "left");
  $tl->LabEntry(-label => "Pixel Width", -textvariable => \$dw)->pack();
}

sub menu_font_preview {
  my $tl = $mw->Toplevel();
  my $cmd = 'xterm -fn $font';

  $f = $tl->Frame()->pack(-side => "bottom");

  $tl->Label(-text => "'\$font' will be replaced below by the name of the font.")->pack();
  my $le = $tl->LabEntry(-label => "Command", -textvariable => \$cmd)->pack(-side => "bottom")->pack();

  $f->Button(-text => "Execute", -command => sub {
	       my $c = $cmd;
	       my ($name) = $font->get_info();
	       $c =~ s/\$font/$name/g;
	       open(OUT, ">temp$$.bdf") or die $!; # XXX: ack, should be way more robust
	       print OUT $font->bdf;
	       close(OUT);
	       system "mkfontdir";
	       system "xset fp+ \$(pwd)";
	       system $c;
	       system "xset fp- \$(pwd)";
	       unlink "temp$$.bdf";
	     })->pack(-side => "left");

  $f->Button(-text => "Close", -command => sub{$tl->destroy})->pack(-side => "left");
  
}

sub menu_options_default_view {
  my $tl = $mw->Toplevel();
  my ($cell_size, $min_x, $min_y, $max_x, $max_y);
  my $f = $tl->Frame()->pack(-side => "bottom");
  $f->Button(-text => "Ok", -command => sub {
	       $default_view = [$cell_size, $min_x, $min_y, $max_x, $max_y];
	       $tl->destroy();
	     })->pack(-side => "left");
  $f->Button(-text => "Cancel", -command => sub{$tl->destroy})->pack(-side => "left");
  $tl->LabEntry(-label => "Cell size", -textvariable => \$cell_size)->pack();
  $tl->LabEntry(-label => "Min x", -textvariable => \$min_x)->pack();
  $tl->LabEntry(-label => "Min y", -textvariable => \$min_y)->pack();
  $tl->LabEntry(-label => "Max x", -textvariable => \$max_x)->pack();
  $tl->LabEntry(-label => "Max y", -textvariable => \$max_y)->pack();
  $f->Button(-text => "Expand to Bounding Box", -command => sub{
	       ($min_x, $min_y, $max_x, $max_y) = 
		 expand_view($min_x, $min_y, $max_x, $max_y);
				  })->pack();
  ($cell_size, $min_x, $min_y, $max_x, $max_y) = @$default_view;
}

sub menu_help_documentation {
  if ($have_pod) {
    $mw->Pod(-file => $0);
  }
  else {
    my $msg = <<EOF;
You do not have Tk::Pod installed. If you did, you could
view the ptkfonted documentation within ptkfonted itself.
Please type 'perldoc ptkfonted' from a shell or
install Tk::Pod, available on your neighborhood CPAN.
EOF
    $msg =~ s/\s+/ /g;
    $mw->messageBox(-type => "Ok", -icon => "error", -message => $msg);
  }
}


sub menu_help_about {
  my $db = 
    $mw->DialogBox
      (
       -title          => 'About',
       -default_button => 'Ok',
       -buttons        => ['Ok'],
      );
  $db->add
    (
     "Label", -text => "ptkfonted v0.4 (helvetica)\n\nJason Reed <godel+\@cmu.edu>\nhttp://cantor.res.cmu.edu/gutenberg/" 
    )->pack();
  $db->Show();
}

sub new_char_edit {
  my ($char) = @_;
  $mw->CharEdit(-font => $font, -char => $char, -update_hook => \&update, -view => $default_view);
}

sub update {
  my $self = shift;
  my ($char) = @_;

  $font->set_pixels($char, $self->get_pixels());
  my $data = $font->get_xbm($char);
  my $image = defined $data ? $mw->Bitmap(-data => $data) : undef;
  $c->itemconfigure($images{$char - $page_offset}, -image => $image) 
    if exists $images{$char - $page_offset};
  dirty(1);
}

sub dirty {
  ($dirty) = (@_);
  if ($dirty && defined $sticky_filename) {
    $file_menu->entryconfigure("Save", -state => "normal");
  }
  else {
    $file_menu->entryconfigure("Save", -state => "disabled");
  }
}

=head1 BUGS

=over 4

=item *

Some features not yet documented

=item *

Probably lots more.

=back

=head1 SEE ALSO

=over 4

L<Font::BDF>

=back

=head1 AUTHOR

Jason Reed E<lt>F<godel+@cmu.edu>E<gt>

This code may be distributed under the same terms as perl itself.

=cut
