linseg

#!/usr/bin/perl

# Linseg helper perltk script.
# written april 2002 by Matthew Gilliard

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

my $i;
my $olt;
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;

# First of all, put everything on the screen:
$main->Label(-text => 'linseg drawer')->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 => 308, height => 311,
                     cursor => 'top_left_arrow');
$c->pack(qw/-side right/);

# Background square (new dot if right-clicked)
my $rect = $c->createRectangle(4,4,304,304, -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,307,7,301,-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(301,1,307,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 ("linseg ...)
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{exit;})->pack(qw/-side right/);
$f->Button(-relief => 'raised', -text => 'Print',
           -command => sub{print "$olt\n";})->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} > 300)){
        $xamount = 0;
    }
    if (($cy + $y - $iinfo->{lasty} > 300) ||
        ($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} <= 300)){
        $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, 304, $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, 304, $endy+4);
        $c->addtag("line$pc", 'withtag', $line);
        $c->lower("line$pc", 'left_point');
    }

# Generate the new "linseg ..." line
    gen_linseg($c);
}

sub gen_linseg(){
# Updates the "linseg ..." line
    my ($c) = @_;
    my $i;
    my $x;
    my $y;
    my $tx;
    my $lastx = 0;
    my $linseg = "linseg ";

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

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

# First section
    $y = int ((300 - $starty)/3)/100;
    $linseg .= $y*($max_y-$min_y) + $min_y . ", ";

# Middle sections
    for ($i=1; $i<=$pc; $i++){
        $x = int(($xlist[$i])/3.0)/100.0;
        $tx = $x - $lastx;
# Account for x_max being a p-field
        if ($max_x =~ m/\Ap\d*/){
            $tx .= "*$max_x";
        }else{
            $tx *= $max_x;
        }
        $y = int((300 - $ylist[$i])/3)/100 * ($max_y-$min_y) + $min_y;
        $linseg .= "$tx, $y, ";
        $lastx = $x;
    }

# Last section
    $tx = 1 - $lastx;
    $y = int((300 - $endy)/3)/100 * ($max_y-$min_y) + $min_y;
    if ($max_x =~ m/\Ap\d*/){
        $tx .= "*$max_x";
    }else{
        $tx *= $max_x;
    }

    $linseg .= "$tx, $y";

# Display the line
    $olt = $linseg;
}