#!/usr/bin/perl -w
# Linear Equation MAnipulator -- a tool for learning how to
# make use of elementary row operations. It helps students
# focus on the higer level steps of such algorithms as
# Gaussian elimination and the simplex method.
# The package perl-tk is required to run this program.

# Author: Chao-Kuei Hung http://www.cyut.edu.tw/~ckhung/
# License: GNU General Public License
# There is currently no document for this program.
# A sample data file can be found at the same directory as 1.txt

use Tk;
use Tk::DialogBox;
use strict;
use Getopt::Std;

my (
    %opts,		# command line options
    $main,		# the main window
    $operation,		# which of the 3 elem. row ops shall we make?
    $showratio,		# should we show ratio of rhs to current column?
    %pivot,		# row/col indices of the current pivot element
    $epsilon,		# a very small, positive number below which
			# numbers are considered as 0
    $rnd,		# parameters for random data generation
    $coefficient,	# coefficients of equations
    @varname,		# variable names
    %color,		# colors for various types of labels
    $history,		# to remember which row operations were performed
    $step,		# Which point of history are we at now?
);

# Note: Variable names can be read from the label widgets and hence
# are not stored as globals. Coefficients, however, lose precision
# in the label widgets and hence need be separately stored as globals.

%opts = (
    f => "fixed",			# font
);
getopts('f:', \%opts);

$epsilon = 1e-5;
$step = 0;
$rnd = {varname=>["x", "y", "z"], low=>-3, high=>3};
$main = MainWindow->new();
$main->protocol("WM_DELETE_WINDOW", \&OnQuit);
$main->{menubar} = $main->Frame(-relief=>"raised", -bd=>2);
$main->{menubar}->pack(-side=>"top", -fill=>"both");
$main->{status} = $main->Frame(-relief=>"sunken", -bd=>2);
$main->{status}->pack(-side=>"bottom", -fill=>"both");
$main->{op} = $main->Frame;
$main->{op}->pack(-side=>"top", -fill=>"both");
$main->{_w} = $main->Scrolled("Canvas", ,-scrollbars=>"osoe");
$main->{_w}->pack(-side=>"top", -fill=>"both", -expand=>"yes");

$main->{menubar}{data} = $main->{menubar}->Menubutton(
    -text=>"Data", -tearoff=>0, -font=>$opts{f}, -menuitems=>[
	["command"=>"Open", -command=>\&OpenFile, -font=>$opts{f}],
	["command"=>"Save As", -command=>\&SaveFile, -font=>$opts{f}],
	["command"=>"Random", -command=>\&GenRandData, -font=>$opts{f}],
	"-",
	["command"=>"Quit", -command=>\&OnQuit, -font=>$opts{f}]
    ]
);
#$main->{menubar}{action} = $main->{menubar}->Menubutton(
#    -text=>"Action", -tearoff=>0, -menuitems=>[
#	["command"=>"Restore", -command=>sub { time_travel(); } ],
#	["command"=>"Undo", -command=>sub { time_travel(-1); } ],
#	["command"=>"Redo", -command=>sub { time_travel(1); } ],
#    ]
#);
$main->{menubar}{options} = $main->{menubar}->Menubutton(
    -text=>"Options", -tearoff=>0, -font=>$opts{f}, -menuitems=>[
	["command"=>"Var Names", -command=>\&SetVarName, -font=>$opts{f}],
    ]
);
$main->{menubar}{help} = $main->{menubar}->Menubutton(
    -text=>"Help", -tearoff=>0, -font=>$opts{f}, -menuitems=>[
	["command"=>"About", -command=>\&HelpAbout, -font=>$opts{f}],
    ]
);

$main->{menubar}{data}->pack(
    $main->{menubar}{options},
    -side=>"left", -fill=>"both");
$main->{menubar}{help}->pack(-side=>"right", -fill=>"both");

$main->{status}{step} = $main->{status}->Label(-textvariable=>\$step, -font=>$opts{f});
$main->{status}{step}->pack(-side=>"left", -fill=>"both");

$main->{status}{ratio} = $main->{status}->Label(-text=>"", -width=>8, -font=>$opts{f});
$main->{status}{ratio}->pack(-side=>"right", -fill=>"both");

my ($op);
foreach $op (qw(scale add swap)) {
    $main->{op}{$op} = $main->{op}->Radiobutton(-variable=>\$operation,
	-text=>$op, -value=>$op, -font=>$opts{f});
    $main->{op}{$op}->pack(-side=>"left");
}
$operation = "scale";
$main->{op}{ratio} = $main->{op}->Checkbutton(-variable=>\$showratio,
    -text=>"ratio", -font=>$opts{f});
$main->{op}{ratio}->pack(-side=>"right");
$main->{op}{bwd} = $main->{op}->Button(-text=>"bwd", -command=>\&step_backward, -font=>$opts{f});
$main->{op}{fwd} = $main->{op}->Button(-text=>"fwd", -command=>\&step_forward, -font=>$opts{f});
$main->{op}{bwd}->pack($main->{op}{fwd}, -side=>"left");

%color = (
    normal => $main->{status}{step}->cget(-bg),
    error => "red",
    pivot => "green",
    ratio => "yellow",
);

OpenFile($ARGV[0]) if ($ARGV[0]);

MainLoop();

#=================================================================
# event handlers

sub OpenFile {
    my ($fn) = @_;
    $fn = $main->getOpenFile(-defaultextension=>".txt", -filetypes=>[
	['Plain Text Files', '.txt'],
	['Linear Equation Files', '.le'],
    ] ) unless $fn;
    return unless $fn;
    my $errmsg;
    if ($fn =~ /\.le$/) {
	$errmsg = read_le($fn);
    } elsif ($fn =~ /\.txt$/) {
	$errmsg = read_txt($fn);
    } else {
	$main->messageBox(-type=>"OK", -title=>"error",
	    -message=>"only .le or .txt files are supported");
	return;
    }

    $main->messageBox( -type=>"OK", -title=>"error",
	-message=>join("\n", @$errmsg) ) if ($errmsg);
    reload_worksp();
}

sub GenRandData {
    my ($row, $col);
    $#$coefficient = $#{$rnd->{varname}};
    @varname = (sort(@{$rnd->{varname}}), "=");
    for ($row=0; $row<=$#$coefficient; ++$row) {
	for ($col=0; $col<=$#varname; ++$col) {
	    $coefficient->[$row][$col] = rand($rnd->{high} - $rnd->{low}) + $rnd->{low};
	}
    }
    reload_worksp();
}

sub SaveFile {
    my ($ans, $fn);
    if (not @varname) {
	$main->messageBox(-type=>"Ok", -title=>"error",
	    -message=>"There is no data in workspace");
	return;
    }
    $fn = $main->getSaveFile(-filetypes=>[
	    ["Plain Text Files",".txt"],
	    ["Linear Eqn Files",".le"],
	    ["RLaB Files",	".r"],
	]
    );
    return unless $fn;
    if ($fn =~ /\.txt$/) {
	$ans = write_txt($fn);
    } elsif ($fn =~ /\.le$/) {
	$ans = write_le($fn);
    } elsif ($fn =~ /\.r$/) {
	$ans = write_r($fn);
    } else {
	$main->messageBox(-type=>"Ok", -title=>"warning",
	    -message=>"Don't know how to save this type of file");
	return;
    }
    $main->messageBox(-type=>"Ok", -title=>"error",
	-message=>"writing '$fn' failed")
	unless $ans;
}

sub OnQuit {
    exit;
}

sub HelpAbout {
    my ($ans) = $main->messageBox(-title=>"About me", -type=>"OK",
	-message=><<eof
Name: Linear Equation MAnipulator
Author: Chao-Kuei Hung
License: GNU General Public License
eof
    );
}

sub SetVarName {
    my ($d, $t0, $t1, $ans);
    $d = $main->DialogBox(-title=>"variable names", -buttons => ["OK", "Cancel"]);
    $t0 = $d->add("Label", -text=>"Set var names for random data generation:", -font=>$opts{f});
    $t1 = $d->add("Entry", -validate=>"key", -font=>$opts{f});#, -validatecommand=>\&CheckVarName, -font=>$opts{f});
    $t1->insert(0, join " ", @{$rnd->{varname}});
    $t0->pack($t1,-side=>"top");
    $ans = $d->Show;
    $t1 = $t1->get();
    $d->destroy();
    return unless $ans eq "OK";
    if ($t1 =~ /^(\s*[a-zA-Z_]\w*)+\s*$/) {
	@{$rnd->{varname}} = split " ", $t1;
    } else {
	$main->messageBox(-type=>"Ok", -title=>"error", -message=>
	    "variable names must be a space-separated list of identifiers")
    }
}

sub CheckVarName {
    my ($nv, $c, $ov, $i, $type) = @_;
    return 0 if (not $c =~ m/[\s\w]/);
    return 0 if $nv =~ m/\b\d/;
    return 0 if $nv =~ m/^\s*$/;
    return 1;
}

#=================================================================
# auxiliary subroutines

sub read_txt {
    my ($fn) = @_;
    return undef unless open F, $fn;
    my ($n, @vn, $c, $errmsg, @t);
    $n = 0;
    while (<F>) {
	s/#.*//;
	next if /^\s*$/;
	@t = split;
	if (@vn) {	# var names already seen. now parse cficients
	    @{$c->[$n]} = @t;
	    @t = grep {!/^[+-]?\d+(\.\d+)?([Ee][+-]?\d+)?$/} @t;
	    if (@t) {
		push @$errmsg, ("$.: parse error near '" .
		    join("','", @t) . "'");
	    } else {
		++$n;
	    }
	} else {
	    @vn = @t;
	    @t = grep {!/^\w+$/;} @t;
	    if (@t) {
		push @$errmsg, ("$.: parse error near '" . join("','", @t) . "'");
		return (undef, $errmsg);
	    }
	}
    }
    close F;
    $#$c = $n - 1;
    $coefficient = $c;
    @varname = (@vn, "=");
    return $errmsg;
}

sub read_le {
    my ($fn) = @_;
    return undef unless open F, $fn;
    my ($row, $col, $c, $errmsg, $lhs, $rhs, @term);
    my ($unp) = '\s*\d+(\.\d*)?';	# pattern for an unsigned number
    $row = 0;
    while (<F>) {
	s/#.*//;
	next if /^\s*$/;
	if (not (($lhs, $rhs) = m/^\s*(.*)=\s*([+-]?$unp)\s*$/)) {
	    push @$errmsg, "$.: missing '=' or right hand side is not a number";
	    next;
	}
	$rhs =~ s/\s//g;
	$lhs = "+" . $lhs unless $lhs =~ /^[+-]/;
	if (not $lhs =~ m/^(([+-])\s*($unp)?\s*(\*\s*)?([_a-zA-Z]\w*)\s*)+$/) {
	    push @$errmsg, "$.: parse error on left hand side";
	    next;
	}
	@term = $lhs =~ m/([+-])\s*($unp)?\s*(\*\s*)?([_a-zA-Z]\w*)/g;
	for ($col=0; $col<$#term; $col+=5) {
	    $term[$col+1] = 1 unless $term[$col+1];
	    $c->[$row]{$term[$col+4]} = $term[$col] . $term[$col+1];
	}
	$c->[$row]{"="} = $rhs;
	++$row;
    }
    close F;
    my (%vn);
    foreach $row (@$c) {
	@vn{keys %$row} = undef;
    }
    my (@i2vn) = sort keys %vn;
    @varname = @i2vn[1..$#i2vn,0];	# move "=" to the end
    undef $coefficient;
    for ($row=0; $row<=$#$c; ++$row) {
	for ($col=0; $col<=$#varname; ++$col) {
	    $coefficient->[$row][$col] = ($c->[$row]{$varname[$col]} or 0);
	}
    }
    return $errmsg;
}

sub write_txt {
    my ($fn) = @_;
    my ($row, $col);
    open F, "> $fn" or return 0;
    print F "      ";
    for ($col=0; $col<$#varname; ++$col) {
	printf F " %-10s", $varname[$col];
    }
    print F "\n";
    for ($row=0; $row<=$#$coefficient; ++$row) {
	for ($col=0; $col<=$#varname; ++$col) {
	    printf F " %10.5f", $coefficient->[$row][$col];
	}
	print F "\n";
    }
    close F or return 0;
    return 1;
}

sub write_le {
    my ($fn) = @_;
    my ($row, $col);
    open F, "> $fn" or return 0;
    for ($row=0; $row<=$#$coefficient; ++$row) {
	for ($col=0; $col<$#varname; ++$col) {
	    printf F " %+10.5f $varname[$col]", $coefficient->[$row][$col];
	}
	printf F " = %+10.5f\n", $coefficient->[$row][$#varname];
    }
    close F or return 0;
    return 1;
}

sub write_r {
    my ($fn) = @_;
    my ($row, $col);
    open F, "> $fn" or return 0;
    print F "b = [";
    for ($row=0; $row<$#$coefficient; ++$row) {
	print F "$coefficient->[$row][$#varname], ";
    }
    print F "$coefficient->[$row][$#varname]]';\nA = [ ...\n";
    for ($row=0; $row<=$#$coefficient; ++$row) {
	for ($col=0; $col<$#varname-1; ++$col) {
	    print F "$coefficient->[$row][$col], ";
	}
	if ($row == $#$coefficient) {
	    print F "$coefficient->[$row][$col]...\n];\n\n# solve(A,b)\n";
	} else {
	    print F "$coefficient->[$row][$col]; ...\n";
	}
    }
    close F or return 0;
    return 1;
}

sub reload_worksp {
    $step = 0;
    undef %pivot;
    undef @$history;
    my ($t) = $main->{_w}->Subwidget("scrolled");
    if (defined $main->{worksp}) {
	$main->{worksp}->destroy();
	$t->delete($main->{"worksp_id_in_canvas"});
	delete $main->{worksp}
    }
    $main->{worksp} = $t->Frame; # (-bd=>4,-bg=>"green");
    $main->{"worksp_id_in_canvas"} = $t->createWindow(0, 0,
	-anchor=>"nw", -window=>$main->{worksp});
    my ($row, $col);
    for ($row=0; $row<=$#$coefficient; ++$row) {
	for ($col=0; $col<=$#varname; ++$col) {
	    $main->{worksp}{"c$row,$col"} = $main->{worksp}->Label(
		-width=>8, -anchor=>"e", -font=>$opts{f});
	    $main->{worksp}{"c$row,$col"}->bind("<ButtonRelease-1>", \&row_op);
	    $main->{worksp}{"c$row,$col"}->bind("<Enter>", \&show_ratio);
	    $main->{worksp}{"c$row,$col"}->bind("<Leave>", \&clear_ratio);
	    $main->{worksp}{"v$row,$col"} = $main->{worksp}->Label(
		-text=>$varname[$col], -anchor=>"w", -font=>$opts{f});
	    $main->{worksp}{"c$row,$col"}->grid(-row=>$row, -column=>$col*2);
	    $main->{worksp}{"v$row,$col"}->grid(-row=>$row, -column=>$col*2+1);
	}
	# special processing for "=" (right hand side)
	$col = $#varname;
	$main->{worksp}{"c$row,$col"}->grid(-row=>$row, -column=>$col*2+1);
	$main->{worksp}{"v$row,$col"}->grid(-row=>$row, -column=>$col*2);
	refresh_row($row);
    }
    # bbox() value is correct only after idletasks()
    $main->idletasks();
    my (@b) = $t->bbox($main->{"worksp_id_in_canvas"});
    $t->configure(-scrollregion=>[@b]);
    # see perldoc Tk::Widget
    $b[3] += $main->{menubar}->reqheight() + $main->{op}->reqheight()
	+ $main->{status}->reqheight();
    # count the size of the scrollbars
    $b[2] += 32; $b[3] += 32;
    # see perldoc Tk::Wm
    $main->maxsize(@b[2,3]);
    my (@cur) = $main->geometry() =~ /(\d+)x(\d+)/;
    $cur[0] = $b[2] if $cur[0] > $b[2];
    $cur[1] = $b[3] if $cur[1] > $b[3];
    $main->geometry("$cur[0]x$cur[1]");
}

#sub get_varname_from_worksp {
#    my ($w) = $main->{worksp};
#    my ($ncol, $nrow) = $w->gridSize();
#    $ncol /= 2;
#    return [map { $w->{"v0,$_"}->cget(-text) } 0..$ncol];
#}

sub refresh_row {
    my ($row, @opts) = @_;
    my ($col);
    for ($col=0; $col<=$#{$coefficient->[$row]}; ++$col) {
	$main->{worksp}{"c$row,$col"}->configure(
	    -text=>sprintf("%+6.3f", $coefficient->[$row][$col]), @opts
	);
	$main->{worksp}{"v$row,$col"}->configure(@opts) if (@opts);
    }
}

sub locate {
    my ($self) = @_;
    my ($t) = { $self->gridInfo() };
    return ($t->{-row}, $t->{-column}/2);
}

sub show_ratio {
    return unless $showratio;
    my ($self) = @_;
    my ($row, $col) = locate($self);
    return if $col >= $#varname;
    my ($t) = abs($coefficient->[$row][$col]) > $epsilon ? sprintf("%+6.3f",
	$coefficient->[$row][$#varname]/$coefficient->[$row][$col]) : "";
    $main->{status}{ratio}->configure(-text=>$t);
    $main->{worksp}{"c$row,$col"}->configure(-bg=>$color{ratio});
    $main->{worksp}{"c$row,$#varname"}->configure(-bg=>$color{ratio});
}

sub clear_ratio {
    return unless $showratio;
    my ($self) = @_;
    my ($row, $col) = locate($self);
    return if $col >= $#varname;
    $main->{status}{ratio}->configure(-text=>"");
    my ($c) = (defined($pivot{row}) and $row == $pivot{row}) ?
	$color{pivot} : $color{normal};
    $main->{worksp}{"c$row,$col"}->configure(-bg=>$c);
    $main->{worksp}{"c$row,$#varname"}->configure(-bg=>$c);
}

sub record {
    $#$history = $step;
    $history->[$step] = [@_]; # (op, $pivot{row}, $picked{row}, scalar)
}

sub step_forward {
    return if $step > $#$history;
    my ($op, $piv, $pic, $sc) = @{$history->[$step]};
    my ($j);
    if ($op eq "scale") {
	$pivot{row} = $pic;
	map { $_ *= $sc; } @{$coefficient->[$pic]};
	refresh_row($piv, -bg=>$color{normal}) if (defined $piv);
	refresh_row($pic, -bg=>$color{pivot});
    } elsif ($op eq "add") {
	for ($j=0; $j<=$#varname; ++$j) {
	    $coefficient->[$pic][$j] -= $sc * $coefficient->[$piv][$j];
	}
	refresh_row($pic);
    } elsif ($op eq "swap") {
	@{$coefficient}[$piv,$pic] = @{$coefficient}[$pic,$piv];
	refresh_row($piv, -bg=>$color{normal});
	refresh_row($pic, -bg=>$color{pivot});
	$pivot{row} = $pic;
    }
    ++$step;
}

sub step_backward {
    return if $step < 1;
    --$step;
    my ($op, $piv, $pic, $sc) = @{$history->[$step]};
    my ($j);
    if ($op eq "scale") {
	$pivot{row} = $piv;
	map { $_ /= $sc; } @{$coefficient->[$pic]};
	refresh_row($pic, -bg=>$color{normal});
	refresh_row($piv, -bg=>$color{pivot}) if (defined $piv);
    } elsif ($op eq "add") {
	for ($j=0; $j<=$#varname; ++$j) {
	    $coefficient->[$pic][$j] += $sc * $coefficient->[$piv][$j];
	}
	refresh_row($pic);
    } elsif ($op eq "swap") {
	@{$coefficient}[$piv,$pic] = @{$coefficient}[$pic,$piv];
	refresh_row($piv, -bg=>$color{pivot});
	refresh_row($pic, -bg=>$color{normal});
	$pivot{row} = $piv;
    }
}

sub row_op {
    my ($self) = @_;
    my (%picked);
    @picked{"row", "col"} = locate($self);
    my ($w) = $main->{worksp};
    my ($ncol, $nrow) = $w->gridSize();
    $ncol /= 2;
    my ($sc, $j);

    if ($operation eq "scale") {
	$sc = $coefficient->[$picked{row}][$picked{col}];
	if (abs($sc) < $epsilon) {
	    $main->messageBox(-type=>"OK", -title=>"error",
		-message=>"pivot element must not be 0");
	    return;
	}
	record("scale", $pivot{row}, $picked{row}, 1/$sc);
	step_forward();
    } elsif ($operation eq "add") {
	return unless defined $pivot{row};
	if ($pivot{row} == $picked{row}) {
	    $main->messageBox(-type=>"OK", -title=>"error",
		-message=>"can't eliminate pivot row itself");
	    return;
	}
	if (abs($coefficient->[$pivot{row}][$picked{col}] - 1) > $epsilon) {
	    $w->{"c$pivot{row},$picked{col}"}->configure(-bg=>$color{error});
            $main->messageBox(-type=>"OK", -title=>"error",
                -message=>"pivot element must be 1");
	    $w->{"c$pivot{row},$picked{col}"}->configure(-bg=>$color{pivot});
            return;
        }
	record("add", $pivot{row}, $picked{row}, 
	    $coefficient->[$picked{row}][$picked{col}] );
	step_forward();
    } elsif ($operation eq "swap") {
	return unless defined $pivot{row};
	record("swap", $pivot{row}, $picked{row});
	step_forward();
    }
}

# Aggregate data are not suitable as arguments for -textvariable
# Statements such as @$x = @$y; will junk old data and allocate
# new data, making -textvariable seem non-functional.
# I learned this from the "swap" case in the row_op function