X-Git-Url: http://git.shiar.net/descalc.git/blobdiff_plain/4e1d9535fda6685e53ce570ca4e4cd6c260f55d3..090ac304afe801cb3e72ced0941ff2a874a98cc9:/descalc.pl

diff --git a/descalc.pl b/descalc.pl
new file mode 100755
index 0000000..e3366e7
--- /dev/null
+++ b/descalc.pl
@@ -0,0 +1,265 @@
+#!/usr/bin/perl
+
+# descalc - desktop calculator
+
+# simple modular reverse polish notition calculator
+# by Shiar <shiar.org>
+
+use strict;
+use warnings;
+use utf8;
+
+use Data::Dumper;
+
+our $VERSION = "1.14";
+
+
+use vars qw(@stack %val %set %alias %action %hook @menu);
+
+%set = (
+	base     => 10,  # decimal; set using commands bin/oct/dec/hex/base
+#	numb     =>  0,  # fixed scientific engineering
+
+	height   =>  4,  # stack depth (lines of stack plus one)
+	width    => 42,  # limit value precision, stetch menu
+); # %set
+
+%alias = (' '=>"enter", "\004"=>"quit");  # rudimentary default key bindings
+
+%action = (
+	"enter" => [ 0, sub {
+		local $_ = defined $val{i} ? $val{i} : $stack[0];
+		undef %val;
+		return defined $_ ? $_ : ();
+	}], # duplication
+
+	"chs"   => [ 1, sub { -$_[0] }], # negative
+
+	"drop"  => [ 1, sub { defined $val{i} ? '' : () }], # drop
+	"back"  => [ 1, sub { () }], # drop essentially
+	"clear" => [ 0, sub { @stack = (); undef %val; () }], # clear all
+
+	"version" => [-2, sub {
+		error("Desktop Calculator Thingy $VERSION by Shiar"); ()
+	}], # version
+); # %action
+
+%hook = map {$_=>[]} qw(
+	showerror showall showmenu showstack showentry
+	postentry precmd postcmd preaction postaction init
+);
+
+my %redraw = (all=>1);  # set flag to refresh whole screen
+
+my %menus = (
+	main => [qw(0 prog> mode>mode)], # main
+	mode => [qw(0 number_format angle_measure coord_system)], #1 mode
+); # %menus
+
+@menu = ($menus{main});  # current menu tree
+
+
+sub redraw(%) {
+	my %obj = @_;
+	while (my ($obj, $level) = each %obj) {
+		$redraw{$obj} = $level;# if $level>$redraw{$obj};
+	} # queue redraw of given objects
+} # redraw
+
+sub error($) {
+	$_->($_[0]) for @{$hook{showerror}};
+	redraw(all=>1);
+} # error
+
+sub addmenu {
+	my ($parent, $menuname) = (shift, shift);
+	$menus{$menuname} = [0];  # create new menu
+	push @{$menus{$parent}}, "$menuname>$menuname";  # link from parent
+	ref $_ ? addmenu($menuname, @$_) : push @{$menus{$menuname}}, $_
+		for @_;  # add menu items (which can be sub-submenus)
+	return $menuname;
+} # addmenu
+
+sub showval;
+sub showval {
+	my ($val, $base, $baseexp) = @_;
+	return '' unless defined $val;
+	return $val if $base==10;  # perl can do the decimal values (much faster)
+
+	$_ = '';  # string to output
+
+	my $sign = $val<0 and $val = abs $val;
+	my $int = int $val;
+
+	my $exp = $val{ex} || 0;
+	while ($int>$base**10) {
+		$int /= $base;
+		$exp++;
+	} # exponent part
+
+	my $frac = $val-$int;
+	while ($int>=1) {
+		my $char = $int%$base;
+		$_ = ($char<10 ? $char : chr($char+55)) . $_;  # add digit [0-9A-Z]
+		$int /= $base;
+	} # integer part
+	$_ .= '.' if $frac>0;
+	for (my $i = 0; length $_<$set{width}-2 && $frac>0; $i++) {
+		$frac *= $base;
+		my $char = int $frac;
+		$frac -= $char;
+		$_ .= $char<10 ? $char : chr($char+55);
+	} # fraction part
+
+	$_ = '-'.$_ if $sign;
+	$_ .= 'e'.showval($exp, $base) if $exp;
+
+	return $_;
+} # showval
+
+
+sub draw {
+	if (%redraw) {
+		my @obj = qw(all menu stack);  # all possible redraw hooks
+		@obj = grep $redraw{$_}, @obj  # keep stuff specified in %redraw
+			unless $redraw{all};  # all keeps everything
+		$_->() for map @{$hook{"show$_"}}, @obj;  # call show$obj hooks
+		%redraw = ();
+	} # do necessary redrawing (queued by &redraw)
+
+	{
+		my $entry = showval($val{i}, $set{base}, $val{ex});
+		$entry .= $_->() for @{$hook{postentry}};  # additional text after val
+		$entry .= $val{alpha} if exists $val{alpha};  # manual command
+		$_->($entry) for @{$hook{showentry}};
+	} # show entry
+} # draw
+
+sub onkey($) {
+	my $key = shift;  # key pressed
+	# command to run into $_ (alias maps keys to commands)
+	$_ = exists $alias{$key} ? $alias{$key} : $key;
+	# manual command entered - make that the new command
+	$_ eq "enter" and exists $val{alpha} and $_ = delete $val{alpha};
+
+	for my $cmd (@{$hook{precmd}}) {
+		$cmd->() and return;  # command was handled by function if returns true
+	} # precmd functions
+
+	exit if $_ eq "quit";  # break out of loop
+
+	if ($_ eq "refresh") {
+		redraw(all=>1);
+	} # refresh
+
+	elsif (/^\033?[A-Z]$/ or exists $val{alpha}) {
+		if (defined $val{i}) {
+			unshift @stack, $val{i};
+			undef %val;
+			redraw(stack=>1);
+		} # enter present value
+
+		if ($_ eq "back") {
+			$val{alpha} = substr $val{alpha}, 0, -1 or delete $val{alpha};
+		} # backspace
+		elsif ($_ eq "drop") {
+			delete $val{alpha};
+		} # drop
+		else {
+			$val{alpha} .= $key =~ /^\033(.)/ ? uc $1 : lc $key;
+		} # add character
+	} # manual command entry
+
+	elsif (/^[\da-f]$/) {
+		m/^[a-z]$/ and $_ = ord($_)-87;  # digit>9
+		$val{i} = 0 unless defined $val{i};
+		$_ = -$_ if $val{i}<0;  # substract from negative value
+		$val{i} = ($val{frac} and $val{frac} *= 10)
+			? $val{i}+$_/$val{frac}  # add digit to fraction
+			: defined $val{ex}
+				? $val{ex} = $val{ex}*$set{base}+$_  # digit to exponent
+				: $val{i}*$set{base}+$_;  # add digit to integer part
+	} # digit
+	elsif ($_ eq '.') {
+		$val{i} = 0 unless defined $val{i};
+		$val{frac} = 1;
+	} # decimal point
+	elsif ($_ eq "eex") {
+		$val{i} = 1 unless defined $val{i};
+		$val{ex} = 0;
+	} # exponent
+	elsif ($_ eq "chs" and defined $val{i}) {
+		$val{i} = -$val{i};
+	} # change sign
+	elsif ($_ eq "back" and defined $val{i}) {
+		$val{i} = ($val{frac} and $val{frac} = int $val{frac}/10)
+			? int($val{i}*$val{frac})/$val{frac}  # backspace fraction digit
+			: int $val{i}/$set{base}  # backspace digit in integer part
+	} # backspace
+
+	elsif (/>([\w ]+)$/) {
+		unshift @menu, $menus{$1};  # go to submenu
+		redraw(menu=>1);
+	} # goto submenu
+
+	elsif (exists $action{$_}) {
+		my ($action, $type, $cmd) = ($_, @{$action{$_}});
+		unshift @stack, $action{enter}[1]->()
+			if $type>0 and defined $val{i};  # auto enter
+
+		if ($type>0 and $type>@stack) {
+			error("insufficient stack arguments for operation");
+			next;
+		} # insufficient arguments
+
+		$_->($type, $action) for @{$hook{preaction}};
+		# put return value(s) of stack-modifying operations (type>=0) at stack
+		$type<0 ? $cmd->() : unshift @stack, $cmd->(splice @stack, 0, $type);
+		$_->($type, $action) for @{$hook{postaction}};
+
+		redraw(stack=>1) if $type>=-1;  # redraw stack
+	} # some operation
+
+	else {
+		$_ = m/^\w*$/ ? qq{"$_"} : join ' ', map ord, split //, $_;
+		error("unrecognised command: $_");  # show string or character codes
+	} # error
+} # onkey
+
+
+our %modules;  # loaded modules
+{
+	my %modskip;
+	$modskip{substr $_, 1}++ for grep /^-/, @ARGV;
+
+	require Cwd;
+	our $path = Cwd::abs_path($0);  # resolve symlinks first
+	    $path = substr($path, 0, rindex($path, '/')+1) || './';
+	# or just use FindBin
+	opendir my($moddir), $path;
+	for my $module (sort readdir $moddir) { # glob "*.pm"
+		$module =~ /^\d{2}_([a-z0-9-]+)(?:_(\w+))?\.pm$/ or next;
+		# files named 00_class_name.pm; ($1, $2) = (class, name)
+		next if exists $modskip{$1} or $2 && exists $modskip{$2};
+		next if defined $modules{$1};  # no such module already loaded
+
+#		defined ($_ = do $module)  # return value means no errors
+#		? (ref $_ and $modules{$1} = $_, $modules{$1}{name} = $2 || "")
+#		: print STDERR $@, "error loading $module\n\n";
+		defined($_ = eval {do $path.$module})  # return value means no errors
+		? (ref $_ and $modules{$1} = $_, $modules{$1}{name} = $2 || "")
+		: print STDERR $@, "error loading $path$module\n";
+	} # load modules
+	closedir $moddir;
+} # find external modules
+
+printf STDERR "descalc %s by Shiar (%s)\n", $VERSION, join "; ",
+	map join(" ", grep $_, $_, $modules{$_}{name}, $modules{$_}{version}),
+	keys %modules;
+
+
+$_->() for @{$hook{init}};
+$menus{main}[10] = "quit";
+
+$hook{main}->(); #todo: error if nothing loaded
+