dct.pl

   1 #!/usr/bin/perl
   2
   3 # DCT - desktop calculator thingy
   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.12.1";
  15
  16 use vars qw(@stack %val %set %alias %action %hook);
  17
  18 %set = (
  19         base     => 10,  # decimal; set using commands bin/oct/dec/hex/base
  20 #       numb     =>  0,  # fixed scientific engineering
  21
  22         height   =>  4,  # stack depth (lines of stack plus one)
  23         width    => 42,  # limit value precision, stetch menu
  24 ); # %set
  25
  26 %alias = (' '=>"enter", "\004"=>"quit");  # rudimentary default key bindings
  27
  28 %action = (
  29         "enter" => [ 0, sub {
  30                 local $_ = defined $val{i} ? $val{i} : $stack[0];
  31                 undef %val;
  32                 return defined $_ ? $_ : ();
  33         }], # duplication
  34
  35         "chs"   => [ 1, sub { -$_[0] }], # negative
  36
  37         "drop"  => [ 1, sub { defined $val{i} ? '' : () }], # drop
  38         "back"  => [ 1, sub { () }], # drop essentially
  39         "clear" => [ 0, sub { @stack = (); undef %val; () }], # clear all
  40
  41         "swap"  => [ 2, sub { reverse @_ }], # swap x<->y
  42         "stack" => [-2, sub {
  43                 my $stackpos if 0;
  44                 $stackpos = 0 unless $stackpos;  # initialize
  45                 $stackpos %= @stack;  # cycle
  46                 $val{i} = $stack[$stackpos++];
  47         }], # stack
  48
  49         "version" => [-2, sub {
  50                 error("Desktop Calculator Thingy $VERSION by Shiar"); ()
  51         }], # version
  52 ); # %action
  53
  54
  55 my $redraw = 2;  # set flag to refresh whole screen
  56
  57 sub redraw($) {
  58         # queue a redraw of level $_[0]
  59         $redraw = $_[0] if $_[0]>$redraw;
  60 } # redraw
  61
  62 sub error($) {
  63         $_->($_[0]) for @{$hook{showerror}};
  64         redraw(2);
  65 } # error
  66
  67 sub showval;
  68 sub showval {
  69         my ($val, $base, $baseexp) = @_;
  70         return '' unless defined $val;
  71         return $val if $base==10;
  72
  73         my $txt = '';
  74
  75         my $sign = $val<0 and $val = abs $val;
  76         my $int = int $val;
  77
  78         my $exp = $val{ex} || 0;
  79         while ($int>$base**10) {
  80                 $int /= $base;
  81                 $exp++;
  82         } # exponent part
  83
  84         my $frac = $val-$int;
  85         while ($int>=1) {
  86                 my $char = $int%$base;
  87                 $txt = ($char<10 ? $char : chr($char+55)) . $txt;
  88                 $int /= $base;
  89         } # integer part
  90         $txt .= '.' if $frac>0;
  91         for (my $i = 0; length $txt<$set{width}-2 && $frac>0; $i++) {
  92                 $frac *= $base;
  93                 my $char = int $frac;
  94                 $frac -= $char;
  95                 $txt .= $char<10 ? $char : chr($char+55);
  96         } # fraction part
  97
  98         $txt = "-".$txt if $sign;
  99         $txt .= 'e'.showval($exp, $base) if $exp;
 100
 101         return $txt;
 102 } # showval
 103
 104
 105 sub draw {
 106         if ($redraw) {
 107                 if ($redraw>1) {
 108                         $_->() for @{$hook{refresh}};
 109                 }
 110                 $_->() for @{$hook{showstack}};
 111                 $redraw = 0;
 112         } # do necessary redrawing
 113
 114         {
 115                 my $entry = showval($val{i}, $set{base}, $val{ex});
 116                 $entry .= $_->() for @{$hook{postentry}};
 117                 $entry .= $val{alpha} if exists $val{alpha};
 118                 $_->($entry) for @{$hook{showentry}};
 119         } # show entry
 120 } # draw
 121
 122 sub onkey($) {
 123         my $key = shift;
 124         $_ = exists $alias{$key} ? $alias{$key} : $key;  # command (alias maps keys to commands)
 125         $_ eq "enter" and exists $val{alpha} and $_ = delete $val{alpha};  # use manual command
 126
 127         for my $cmd (@{$hook{precmd}}) {
 128                 $cmd->() and return;  # command was handled by function if returns true
 129         } # precmd functions
 130
 131         exit if $_ eq "quit";  # break out of loop
 132
 133         if ($_ eq "refresh") {
 134                 redraw(2);
 135         } # refresh
 136
 137         elsif (/^\033?[A-Z]$/ or exists $val{alpha}) {
 138                 if (defined $val{i}) {
 139                         unshift @stack, $val{i};
 140                         undef %val;
 141                         redraw(1);
 142                 } # enter present value
 143
 144                 if ($_ eq "back") {
 145                         $val{alpha} = substr $val{alpha}, 0, -1 or delete $val{alpha};
 146                 } # backspace
 147                 elsif ($_ eq "drop") {
 148                         delete $val{alpha};
 149                 } # drop
 150                 else {
 151                         $val{alpha} .= $key =~ /^\033(.)/ ? uc $1 : lc $key;
 152                 } # add character
 153         } # manual command entry
 154
 155         elsif (/^[\da-f]$/) {
 156                 m/^[a-z]$/ and $_ = ord($_)-87;  # digit>9
 157                 $val{i} = 0 unless defined $val{i};
 158                 $_ = -$_ if $val{i}<0;  # substract from negative value
 159                 $val{i} = ($val{frac} and $val{frac} *= 10)
 160                         ? $val{i}+$_/$val{frac}  # add digit to fraction
 161                         : defined $val{ex} ? $val{ex} = $val{ex}*$set{base}+$_  # digit to exponent
 162                         : $val{i}*$set{base}+$_;  # add digit to integer part
 163         } # digit
 164         elsif ($_ eq '.') {
 165                 $val{i} = 0 unless defined $val{i};
 166                 $val{frac} = 1;
 167         } # decimal point
 168         elsif ($_ eq "eex") {
 169                 $val{i} = 1 unless defined $val{i};
 170                 $val{ex} = 0;
 171         } # exponent
 172         elsif ($_ eq "chs" and defined $val{i}) {
 173                 $val{i} = -$val{i};
 174         } # change sign
 175         elsif ($_ eq "back" and defined $val{i}) {
 176                 $val{i} = ($val{frac} and $val{frac} = int $val{frac}/10)
 177                         ? int($val{i}*$val{frac})/$val{frac}  # backspace fraction digit
 178                         : int $val{i}/$set{base}  # backspace digit in integer part
 179         } # backspace
 180
 181         elsif (exists $action{$_}) {
 182                 my ($action, $type, $cmd) = ($_, @{$action{$_}});
 183                 unshift @stack, $action{enter}[1]->() if $type>0 and defined $val{i};  # auto enter
 184
 185                 if ($type>0 and $type>@stack) {
 186                         error("insufficient stack arguments for operation");
 187                         next;
 188                 } # insufficient arguments
 189
 190                 $_->($type, $action) for @{$hook{preaction}};
 191                 # put return value(s) of stack-modifying operations (type>=0) at stack
 192                 $type<0 ? $cmd->() : unshift @stack, $cmd->(splice @stack, 0, $type);
 193                 $_->($type, $action) for @{$hook{postaction}};
 194
 195                 redraw(1) if $type>=-1;  # redraw stack
 196         } # some operation
 197
 198         else {
 199                 error(
 200                         "unrecognised command: "  # show string or character codes
 201                         . (m/^\w*$/ ? qq{"$_"} : join ' ', map ord, split //, $_)
 202                 );
 203         } # error
 204 } # onkey
 205
 206
 207 our %modules;
 208 {
 209         my %modskip;
 210         $modskip{substr $_, 1}++ for grep /^-/, @ARGV;
 211         opendir my $moddir, ".";
 212         for my $module (sort readdir $moddir) { # glob "*.pm"
 213                 $module =~ /^\d{2}_([a-z0-9-]+)(?:_(\w+))?\.pm$/ or next;
 214                 # files named 00_class_name.pm; ($1, $2) = (class, name)
 215                 next if exists $modskip{$1} or $2 && exists $modskip{$2};
 216                 next if defined $modules{$1};  # no such module already loaded
 217                 defined ($_ = do $module)  # return value means no errors
 218                 ? (ref $_ and $modules{$1} = $_, $modules{$1}{name} = $2 || "")
 219                 : print STDERR $@, "error loading $module\n\n";
 220         } # load modules
 221         closedir $moddir;
 222 } # find external modules
 223
 224 printf STDERR "DCT %s by Shiar (%s)\n", $VERSION, join "; ",
 225         map join(" ", grep $_, $_, $modules{$_}{name}, $modules{$_}{version}),
 226         keys %modules;
 227
 228
 229 $_->() for @{$hook{init}};
 230
 231 $hook{main}->();
 232