brkpt

#!/usr/bin/perl

# Linseg helper perltk script.
# written april 2002 by Matthew Gilliard
# Adjusted to produce breakpoint files
# September 2002 John ffitch
# Mainly names on screen and output format

use Tk;
use strict;
use vars qw($main);

my $scale = 500;
my $i;
my $olt;
my $folt;
my $pc = 0;
my $max_x = 1;
my $min_y = 0;
my $max_y = 1;
my $main = new MainWindow;
my @xlist;
my @ylist;
my @point;
my %iinfo;
my $fname;
if (@ARGV){
    $fname = $ARGV[0];
}else{
    $fname = "bkptfi";
}
open(FF,'>',$fname)
  or die "Cannot open output";

# First of all, put everything on the screen:
$main->Label(-text => 'breakpoint file creator')->pack;

# Frames for arranging things in
my $bf = $main->Frame->pack;
my $bft = $bf->Frame->pack(qw/-side top/);
my $bfb = $bf->Frame->pack(qw/-side bottom -fill x/);
my $ftl = $bft->Frame->pack(qw/-side left -fill y/);
my $ftr = $bft->Frame->pack(qw/-side right/);

# X-axis max entry.  There is no x-min (see help file).
$bfb->Entry(-relief => 'sunken', -textvariable => \$max_x,
            -width => 4)->pack(qw/-side right/);

# Y-axis entries
$ftl->Entry(-relief => 'sunken', -textvariable => \$min_y,
            -width => 4)->pack(qw/-side bottom/);
$ftl->Entry(-relief => 'sunken', -textvariable => \$max_y,
            -width => 4)->pack(qw/-side top/);

#Drawing canvs (the graph area)
my $c = $ftr->Canvas(relief => 'raised', width => $scale+8,
                     height => $scale+11, cursor => 'top_left_arrow');
$c->pack(qw/-side right/);

# Background square (new dot if right-clicked)
my $rect = $c->createRectangle(4,4,$scale+4,$scale+4, -fill => 'white');
$c->addtag("background", 'withtag', $rect);
$c->bind("background", '<3>' => [sub{new_dot(shift, $Tk::event->x,
                                             $Tk::event->y)}]);

# Start point of graph
my $leftpoint = $c->createOval(1,$scale+7,7,$scale+1,
                               -width => 1, -outline => 'black',
                               -fill => 'darkred');
$c->addtag("left_point", 'withtag', $leftpoint);
$c->bind("left_point", '<Enter>' => [sub{shift->itemconfigure(@_)},
                                     'current', -fill => 'Skyblue2']);
$c->bind("left_point", '<Leave>' => [sub{shift->itemconfigure(@_)},
                                     'current', -fill => 'darkred']);
$c->bind("left_point", '<B1-Motion>' => [sub{drag_edge(shift, $Tk::event->x,
                                                       $Tk::event->y, \%iinfo)}]);
$c->bind("left_point", '<1>' => [sub{start_drag_point(shift, $Tk::event->x,
                                                      $Tk::event->y, \%iinfo)}]);

# End point of graph
my $rightpoint = $c->createOval($scale+1,1,$scale+7,7,
                                -width => 1, -outline => 'black',
                                -fill => 'darkred');
$c->addtag("right_point", 'withtag', $rightpoint);
$c->bind("right_point", '<Enter>' => [sub{shift->itemconfigure(@_)},
                                      'current', -fill => 'Skyblue2']);
$c->bind("right_point", '<Leave>' => [sub{shift->itemconfigure(@_)},
                                      'current', -fill => 'darkred']);
$c->bind("right_point", '<B1-Motion>' => [sub{drag_edge(shift,
                                                        $Tk::event->x,
                                                        $Tk::event->y, \%iinfo)}]);
$c->bind("right_point", '<1>' => [sub{start_drag_point(shift,
                                                       $Tk::event->x,
                                                       $Tk::event->y, \%iinfo)}]);

# output line ("brkpt ...)
my $outline = $main->Entry(-textvariable => \$olt)->pack(qw/-fill x/);

# Row of buttons (Print, Refresh, Exit)
my $f = $main->Frame->pack;
$f->Button(-relief => 'raised', -text => 'Exit',
           -command => sub{print "$olt\n";
                           print FF "$folt"; exit;})->pack(qw/-side right/);
$f->Button(-relief => 'raised', -text => 'Show',
           -command => sub{print "$olt\n";})->pack(qw/-side left/);
$f->Button(-relief => 'raised', -text => 'Abort',
           -command => sub{exit;})->pack(qw/-side left/);
$f->Button(-relief => 'raised', -text => 'Refresh',
           -command => sub{draw_lines($c)} )->pack(qw/-side left/);

# Initialise screen
draw_lines($c);

# Start responding to user input
MainLoop;


#
#Start of subroutines
#


sub new_dot(){
# This is called by a right-click on the background
# It adds the dot, and redraws the lines to include the new dot.
    my ($c, $x, $y) = @_;
    $x = $c->canvasx($x);
    $y = $c->canvasy($y);
    draw_dot($x, $y, ++$pc);
    draw_lines($c);
}

sub draw_dot(){
# This is called (only) by new_dot()
# It draws the new dot in the right place and sets its behaviour

    my ($xpos, $ypos) = @_;
    $point[$pc] = $c->createOval($xpos-3,$ypos-3,$xpos+3,$ypos+3,
                                 -width => 1, -outline => 'black', -fill => 'red');
    $c->addtag("p$pc", 'withtag', $point[$pc]);
    $c->bind("p$pc", '<Enter>' => [sub{shift->itemconfigure(@_)},
                                   'current', -fill => 'Skyblue2']);
    $c->bind("p$pc", '<Leave>' => [sub{shift->itemconfigure(@_)},
                                   'current', -fill => 'Red']);
    $c->bind("p$pc", '<B1-Motion>' => [sub{drag_point(shift,
                                                      $Tk::event->x,
                                                      $Tk::event->y, \%iinfo)}]);
    $c->bind("p$pc", '<1>' => [sub{start_drag_point(shift,
                                                    $Tk::event->x,
                                                    $Tk::event->y, \%iinfo)}]);
    $c->bind("p$pc", '<3>' => [sub{remove_dot(shift)}]);
}

sub remove_dot(){
# This is called when a dot is right-clicked on
# It deletes the dot in question, resorts the array of coords and redraws the lines
    my ($c) = @_;
    $c->delete('current');
    getsort();
    draw_lines($c);
}

sub getsort(){
# This is called whenever a dot is moved, added or removed.
# It finds all the dots' coordinates, sticks them in 2 arrays, and sorts them
    my $i;
    my $j = 0;
    my $tx;
    my $ty;
    my $temp;
# clear old arrays
    @xlist = ();
    @ylist = ();
# find dots, and populate arrays
    for ($i=0; $i<=100; $i++){
        ($tx,,$ty,) = $c->coords("p$i");
        if ($tx && $ty){
            $xlist[$j] = int $tx - 1;
            $ylist[$j++] = int $ty - 1;
        }
    }

    $pc = $j;

# Sort arrays in order of increasing x value.
    for ($j=0; $j<$pc; $j++){
        for ($i=0; $i<$pc; $i++){
            if ($xlist[$i] > $xlist[$i+1]){
                $temp = $xlist[$i];
                $xlist[$i] = $xlist[$i+1];
                $xlist[$i+1] = $temp;

                $temp = $ylist[$i];
                $ylist[$i] = $ylist[$i+1];
                $ylist[$i+1] = $temp;
            }
        }
    }
}

sub start_drag_point(){
# Called when a dot is clicked on
# Gets the dot's coords, ready for it to be dragged
    my ($c, $x, $y, $iinfo) = @_;
    $iinfo->{lastx} = $c->canvasx($x);
    $iinfo->{lasty} = $c->canvasy($y);
}

sub drag_point(){
# Called when a dot is dragged
    my ($c, $x, $y, $iinfo) = @_;
    my $cx;
    my $cy;
    $x = $c->canvasx($x);
    $y = $c->canvasy($y);
    ($cx,,$cy,) = $c->coords('current');
    my $xamount = $x - $iinfo->{lastx};
    my $yamount = $y - $iinfo->{lasty};

# Keep the dot inside the square, not just the canvas
    if (($cx + $x - $iinfo->{lastx} < 3) ||
        ($cx + $x - $iinfo->{lastx} > $scale)){
        $xamount = 0;
    }
    if (($cy + $y - $iinfo->{lasty} > $scale) ||
        ($cy + $y - $iinfo->{lasty} < 1)){
        $yamount = 0;
    }
    $c->move('current', $xamount, $yamount);
    $iinfo->{lastx} = $x;
    $iinfo->{lasty} = $y;

# Redraw lines
    draw_lines($c);
}

sub drag_edge(){
# The same as drag_point, but for the end dots, only up and down.
    my ($c, $x, $y, $iinfo) = @_;
    my $cx;
    my $cy;
    $x = $c->canvasx($x);
    $y = $c->canvasy($y);
    ($cx,,$cy,) = $c->coords('current');

# Not off the top or bottom, please
    if (($cy + $y - $iinfo->{lasty} > 0) &&
        ($cy + $y - $iinfo->{lasty} <= $scale)){
        $c->move('current', 0, $y-$iinfo->{lasty});
        $iinfo->{lastx} = $x;
        $iinfo->{lasty} = $y;
    }

# Redraw lines
    draw_lines($c);
}


sub draw_lines(){
# Called whenever the lines need redrawing (all the time)
    my ($c) = @_;
    my $i;

# Refresh array of points
    getsort();

# Delete all lines
    for ($i=0; $i<=100; $i++){
        $c->delete("line$i");
    }

# Use end points
    my ($i,$starty,,) = $c->coords('left_point');
    my ($i,$endy,,) = $c->coords('right_point');

    $starty -= 1;
    $endy -= 1;

    if ($pc == 0){
# Line only has 2 points
        my $line = $c->createLine(4, $starty+4, $scale+4, $endy+4);
        $c->addtag('line0', 'withtag', $line);
        $c->lower('line0', 'left_point');

    }else{
# First section
        my $line = $c->createLine(4, $starty+4, $xlist[1]+4, $ylist[1]+4);
        $c->addtag('line0', 'withtag', $line);
        $c->lower('line0', 'left_point');

# Middle sections
        for ($i=1; $i<$pc; $i++){
            my $line = $c->createLine($xlist[$i]+4, $ylist[$i]+4,
                                      $xlist[$i+1]+4, $ylist[$i+1]+4);
        $c->addtag("line$i", 'withtag', $line);
        $c->lower("line$i", 'left_point');
        }

# Last section
        my $line = $c->createLine($xlist[$pc]+4, $ylist[$pc]+4, $scale+4, $endy+4);
        $c->addtag("line$pc", 'withtag', $line);
        $c->lower("line$pc", 'left_point');
    }

# Generate the new "brkpt ..." line
    gen_brkpt($c);
    print_coords($c);
}

sub gen_brkpt(){
# Updates the "brkpt ..." line
    my ($c) = @_;
    my $i;
    my $x;
    my $y;
    my $tx;
    my $brkpt = "(0, ";

    my ($i,$starty,,) = $c->coords('left_point');
    my ($i,$endy,,) = $c->coords('right_point');

    $starty -= 1;
    $endy -= 1;

# First section
    $y = int (($scale - $starty)/($scale/100.0))/100;
    $brkpt .=  $y*($max_y-$min_y) + $min_y . ") ";

# Middle sections
    for ($i=1; $i<=$pc; $i++){
        $x = int(($xlist[$i])/($scale/100.0))/100.0;
        $tx = $x;
        $tx *= $max_x;
        $y = int(($scale - $ylist[$i])/($scale/100.0))/100 *
                                        ($max_y-$min_y) + $min_y;
        $brkpt .= "($tx, $y) ";
    }

# Last section
    $tx = 1;
    $y = int(($scale - $endy)/($scale/100.0))/100 * ($max_y-$min_y) + $min_y;
    $tx *= $max_x;
    $brkpt .= "($tx, $y)";

# Display the line
    $olt = $brkpt;
}

sub print_coords(){
    my ($c) = @_;
    my $i;
    my $x;
    my $y;
    my $tx;
    my $fbrkpt = "0\t";

    my ($i,$starty,,) = $c->coords('left_point');
    my ($i,$endy,,) = $c->coords('right_point');

    $starty -= 1;
    $endy -= 1;

# First section
    $y = int (($scale - $starty)/($scale/100.0))/100;
    $fbrkpt .=  $y*($max_y-$min_y) + $min_y . "\n";

# Middle sections
    for ($i=1; $i<=$pc; $i++){
        $x = int(($xlist[$i])/($scale/100.0))/100.0;
        $tx = $x;
        $tx *= $max_x;
        $y = int(($scale - $ylist[$i])/($scale/100.0))/100 *
                                        ($max_y-$min_y) + $min_y;
        $fbrkpt .= "$tx\t$y\n";
    }

# Last section
    $tx = 1;
    $y = int(($scale - $endy)/($scale/100.0))/100 * ($max_y-$min_y) + $min_y;
    $tx *= $max_x;
    $fbrkpt .= "$tx\t$y\n";

    $folt = $fbrkpt;
}