--- /dev/null
+#!/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
+
git.shiar.nl / descalc.git / blobdiff