descalc.pl

   1 #!/usr/bin/perl
   2
   3 # descalc - desktop calculator
   4
   5 # simple modular reverse polish notition calculator
   6 # by Shiar <shiar.org>
   7
   8 use strict;
   9 use warnings;
  10 use utf8;
  11
  12 use Data::Dumper;
  13
  14 our $VERSION = "1.14";
  15
  16
  17 use vars qw(@stack %val %set %alias %action %hook @menu);
  18
  19 %set = (
  20         base     => 10,  # decimal; set using commands bin/oct/dec/hex/base
  21 #       numb     =>  0,  # fixed scientific engineering
  22
  23         height   =>  4,  # stack depth (lines of stack plus one)
  24         width    => 42,  # limit value precision, stetch menu
  25 ); # %set
  26
  27 %alias = (' '=>"enter", "\004"=>"quit");  # rudimentary default key bindings
  28
  29 %action = (
  30         "enter" => [ 0, sub {
  31                 local $_ = defined $val{i} ? $val{i} : $stack[0];
  32                 undef %val;
  33                 return defined $_ ? $_ : ();
  34         }], # duplication
  35
  36         "chs"   => [ 1, sub { -$_[0] }], # negative
  37
  38         "drop"  => [ 1, sub { defined $val{i} ? '' : () }], # drop
  39         "back"  => [ 1, sub { () }], # drop essentially
  40         "clear" => [ 0, sub { @stack = (); undef %val; () }], # clear all
  41
  42         "version" => [-2, sub {
  43                 error("Desktop Calculator Thingy $VERSION by Shiar"); ()
  44         }], # version
  45 ); # %action
  46
  47 %hook = map {$_=>[]} qw(
  48         showerror showall showmenu showstack showentry
  49         postentry precmd postcmd preaction postaction init
  50 );
  51
  52 my %redraw = (all=>1);  # set flag to refresh whole screen
  53
  54 my %menus = (
  55         main => [qw(0 prog> mode>mode)], # main
  56         mode => [qw(0 number_format angle_measure coord_system)], #1 mode
  57 ); # %menus
  58
  59 @menu = ($menus{main});  # current menu tree
  60
  61
  62 sub redraw(%) {
  63         my %obj = @_;
  64         while (my ($obj, $level) = each %obj) {
  65                 $redraw{$obj} = $level;# if $level>$redraw{$obj};
  66         } # queue redraw of given objects
  67 } # redraw
  68
  69 sub error($) {
  70         $_->($_[0]) for @{$hook{showerror}};
  71         redraw(all=>1);
  72 } # error
  73
  74 sub addmenu {
  75         my ($parent, $menuname) = (shift, shift);
  76         $menus{$menuname} = [0];  # create new menu
  77         push @{$menus{$parent}}, "$menuname>$menuname";  # link from parent
  78         ref $_ ? addmenu($menuname, @$_) : push @{$menus{$menuname}}, $_
  79                 for @_;  # add menu items (which can be sub-submenus)
  80         return $menuname;
  81 } # addmenu
  82
  83 sub showval;
  84 sub showval {
  85         my ($val, $base, $baseexp) = @_;
  86         return '' unless defined $val;
  87         return $val if $base==10;  # perl can do the decimal values (much faster)
  88
  89         $_ = '';  # string to output
  90
  91         my $sign = $val<0 and $val = abs $val;
  92         my $int = int $val;
  93
  94         my $exp = $val{ex} || 0;
  95         while ($int>$base**10) {
  96                 $int /= $base;
  97                 $exp++;
  98         } # exponent part
  99
 100         my $frac = $val-$int;
 101         while ($int>=1) {
 102                 my $char = $int%$base;
 103                 $_ = ($char<10 ? $char : chr($char+55)) . $_;  # add digit [0-9A-Z]
 104                 $int /= $base;
 105         } # integer part
 106         $_ .= '.' if $frac>0;
 107         for (my $i = 0; length $_<$set{width}-2 && $frac>0; $i++) {
 108                 $frac *= $base;
 109                 my $char = int $frac;
 110                 $frac -= $char;
 111                 $_ .= $char<10 ? $char : chr($char+55);
 112         } # fraction part
 113
 114         $_ = '-'.$_ if $sign;
 115         $_ .= 'e'.showval($exp, $base) if $exp;
 116
 117         return $_;
 118 } # showval
 119
 120
 121 sub draw {
 122         if (%redraw) {
 123                 my @obj = qw(all menu stack);  # all possible redraw hooks
 124                 @obj = grep $redraw{$_}, @obj  # keep stuff specified in %redraw
 125                         unless $redraw{all};  # all keeps everything
 126                 $_->() for map @{$hook{"show$_"}}, @obj;  # call show$obj hooks
 127                 %redraw = ();
 128         } # do necessary redrawing (queued by &redraw)
 129
 130         {
 131                 my $entry = showval($val{i}, $set{base}, $val{ex});
 132                 $entry .= $_->() for @{$hook{postentry}};  # additional text after val
 133                 $entry .= $val{alpha} if exists $val{alpha};  # manual command
 134                 $_->($entry) for @{$hook{showentry}};
 135         } # show entry
 136 } # draw
 137
 138 sub onkey($) {
 139         my $key = shift;  # key pressed
 140         # command to run into $_ (alias maps keys to commands)
 141         $_ = exists $alias{$key} ? $alias{$key} : $key;
 142         # manual command entered - make that the new command
 143         $_ eq "enter" and exists $val{alpha} and $_ = delete $val{alpha};
 144
 145         for my $cmd (@{$hook{precmd}}) {
 146                 $cmd->() and return;  # command was handled by function if returns true
 147         } # precmd functions
 148
 149         exit if $_ eq "quit";  # break out of loop
 150
 151         if ($_ eq "refresh") {
 152                 redraw(all=>1);
 153         } # refresh
 154
 155         elsif (/^\033?[A-Z]$/ or exists $val{alpha}) {
 156                 if (defined $val{i}) {
 157                         unshift @stack, $val{i};
 158                         undef %val;
 159                         redraw(stack=>1);
 160                 } # enter present value
 161
 162                 if ($_ eq "back") {
 163                         $val{alpha} = substr $val{alpha}, 0, -1 or delete $val{alpha};
 164                 } # backspace
 165                 elsif ($_ eq "drop") {
 166                         delete $val{alpha};
 167                 } # drop
 168                 else {
 169                         $val{alpha} .= $key =~ /^\033(.)/ ? uc $1 : lc $key;
 170                 } # add character
 171         } # manual command entry
 172
 173         elsif (/^[\da-f]$/) {
 174                 m/^[a-z]$/ and $_ = ord($_)-87;  # digit>9
 175                 $val{i} = 0 unless defined $val{i};
 176                 $_ = -$_ if $val{i}<0;  # substract from negative value
 177                 $val{i} = ($val{frac} and $val{frac} *= 10)
 178                         ? $val{i}+$_/$val{frac}  # add digit to fraction
 179                         : defined $val{ex}
 180                                 ? $val{ex} = $val{ex}*$set{base}+$_  # digit to exponent
 181                                 : $val{i}*$set{base}+$_;  # add digit to integer part
 182         } # digit
 183         elsif ($_ eq '.') {
 184                 $val{i} = 0 unless defined $val{i};
 185                 $val{frac} = 1;
 186         } # decimal point
 187         elsif ($_ eq "eex") {
 188                 $val{i} = 1 unless defined $val{i};
 189                 $val{ex} = 0;
 190         } # exponent
 191         elsif ($_ eq "chs" and defined $val{i}) {
 192                 $val{i} = -$val{i};
 193         } # change sign
 194         elsif ($_ eq "back" and defined $val{i}) {
 195                 $val{i} = ($val{frac} and $val{frac} = int $val{frac}/10)
 196                         ? int($val{i}*$val{frac})/$val{frac}  # backspace fraction digit
 197                         : int $val{i}/$set{base}  # backspace digit in integer part
 198         } # backspace
 199
 200         elsif (/>([\w ]+)$/) {
 201                 unshift @menu, $menus{$1};  # go to submenu
 202                 redraw(menu=>1);
 203         } # goto submenu
 204
 205         elsif (exists $action{$_}) {
 206                 my ($action, $type, $cmd) = ($_, @{$action{$_}});
 207                 unshift @stack, $action{enter}[1]->()
 208                         if $type>0 and defined $val{i};  # auto enter
 209
 210                 if ($type>0 and $type>@stack) {
 211                         error("insufficient stack arguments for operation");
 212                         next;
 213                 } # insufficient arguments
 214
 215                 $_->($type, $action) for @{$hook{preaction}};
 216                 # put return value(s) of stack-modifying operations (type>=0) at stack
 217                 $type<0 ? $cmd->() : unshift @stack, $cmd->(splice @stack, 0, $type);
 218                 $_->($type, $action) for @{$hook{postaction}};
 219
 220                 redraw(stack=>1) if $type>=-1;  # redraw stack
 221         } # some operation
 222
 223         else {
 224                 $_ = m/^\w*$/ ? qq{"$_"} : join ' ', map ord, split //, $_;
 225                 error("unrecognised command: $_");  # show string or character codes
 226         } # error
 227 } # onkey
 228
 229
 230 our %modules;  # loaded modules
 231 {
 232         my %modskip;
 233         $modskip{substr $_, 1}++ for grep /^-/, @ARGV;
 234
 235         require Cwd;
 236         our $path = Cwd::abs_path($0);  # resolve symlinks first
 237             $path = substr($path, 0, rindex($path, '/')+1) || './';
 238         # or just use FindBin
 239         opendir my($moddir), $path;
 240         for my $module (sort readdir $moddir) { # glob "*.pm"
 241                 $module =~ /^\d{2}_([a-z0-9-]+)(?:_(\w+))?\.pm$/ or next;
 242                 # files named 00_class_name.pm; ($1, $2) = (class, name)
 243                 next if exists $modskip{$1} or $2 && exists $modskip{$2};
 244                 next if defined $modules{$1};  # no such module already loaded
 245
 246 #               defined ($_ = do $module)  # return value means no errors
 247 #               ? (ref $_ and $modules{$1} = $_, $modules{$1}{name} = $2 || "")
 248 #               : print STDERR $@, "error loading $module\n\n";
 249                 defined($_ = eval {do $path.$module})  # return value means no errors
 250                 ? (ref $_ and $modules{$1} = $_, $modules{$1}{name} = $2 || "")
 251                 : print STDERR $@, "error loading $path$module\n";
 252         } # load modules
 253         closedir $moddir;
 254 } # find external modules
 255
 256 printf STDERR "descalc %s by Shiar (%s)\n", $VERSION, join "; ",
 257         map join(" ", grep $_, $_, $modules{$_}{name}, $modules{$_}{version}),
 258         keys %modules;
 259
 260
 261 $_->() for @{$hook{init}};
 262 $menus{main}[10] = "quit";
 263
 264 $hook{main}->(); #todo: error if nothing loaded
 265