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