 |  |
C.7. tkhp16c
tkhp16c is an RPN calculator we used for a splash screen example in Chapter 15, "Anatomy of the MainLoop". See Figure 15-6.
package Tk;
use Tk::bindDump;
# M A I N
package main;
use Tk;
use Tk::MacProgressBar;
use Tk::Splashscreen;
use Tk::widgets qw/Compound ROText/;
use subs qw/build_button_rows build_calculator build_help_window end splash/;
use strict;
my $mw = MainWindow->new;
$mw->withdraw;
$mw->title('Hewlett-Packard 16C Computer Scientist RPN Calculator');
$mw->iconname('HP 16C');
$mw->configure(-background => $GRAY_LIGHTEST);
my $splash = splash; # build Splashscreen
$splash->Splash; # show Splashscreen
build_help_window;
build_calculator;
$MAC_PB->set($MAC_PB_P = 100);
$splash->Destroy; # tear down Splashscreen
$mw->deiconify; # show calculator
MainLoop;
# Miscellaneous subroutines.
sub build_button_rows {
my ($parent, $button_descriptions) = @_;
foreach my $row (@$button_descriptions) {
my $frame = $parent->Frame(-background => $GRAY_LIGHTEST);
foreach my $buttons (@$row) {
my ($p1, $p2, $p3, $color, $func) = @$buttons;
$frame->Key(
topl => $p2,
-butl => $p1,
-botl => $p3,
-background => $color,
-command => $func,
);
}
$frame->pack(qw/-side top -expand 1 -fill both/);
$MAC_PB->set($MAC_PB_P += 10);
}
} # end build_button_rows
sub build_calculator {
&on; &on; # on/off kluge to initialize HP stack
# LED display, help button, and HP logo.
my $tf = $mw->Frame(-background => $SILVER);
$tf->pack(qw/-side top -fill both -expand 1/);
$tf->Label(
-relief => 'sunken',
-borderwidth => 10,
-background => 'honeydew4',
-width => 30,
-foreground => 'black',
-font => ['arial', 14, 'bold'],
-textvariable => \$XV,
-anchor => 'w',
)->pack(qw/-side left -expand 1 -fill x -padx 70/);
my $hp = $tf->Button(-text => $MODEL, -relief => 'raised',
-command => sub {$ONOFF = 1; &on; &exit});
$hp->pack(qw/-side right -expand 1 -fill both -padx 20 -pady 10/);
$hp->bind('<Enter>' => sub {$_[0]->configure(-text => "Quit\n--\n16C")});
$hp->bind('<Leave>' => sub {$_[0]->configure(-text => $MODEL)});
# Horizontal black and silver lines + vertical left/right silver lines.
$mw->Frame(qw/-background black -height 10/)->pack(qw/-fill x -expand 1/);
$mw->Frame(-bg => $SILVER, -height => 5)->pack(qw/-fill x -expand 1/);
my $frame0 = $mw->Frame(-background => $GRAY_LIGHTEST);
$frame0->pack(qw/-side top -fill both -expand 1/);
$frame0->Frame(-width => 5, -bg => $SILVER)->
pack(qw/-side left -expand 1 -fill y/);
$frame0->Frame(-width => 5, -bg => $SILVER)->
pack(qw/-side right -expand 1 -fill y/);
# These frames hold all the calculator keys.
my $frame1 = $frame0->Frame->pack(qw/-side top -fill both -expand 1/);
my $frame2 = $frame0->Frame->pack(qw/-side left -fill both -expand 1/);
my $frame3 = $frame0->Frame->pack(qw/-side right -fill both -expand 1/);
# Bottom finishing detail.
$mw->Frame(
-background => $SILVER,
-width => 20,
-height => 25,
)->pack(qw/-side left -expand 0/);
$mw->Label(
-text => ' H E W L E T T . P A C K A R D ',
-font => ['courier', 14, 'bold'],
-foreground => $SILVER,
-background => $GRAY_LIGHTEST,
)->pack(qw/-side left -expand 0/);
$mw->Frame(
-background => $SILVER,
-height => 25,
)->pack(qw/-side left -expand 1 -fill x/);
my $quest = $mw->Button(
-text => '?',
-font => '6x9',
-relief => 'flat',
-highlightthickness => 0,
-background => $SILVER,
-borderwidth => 0,
-pady => 0,
-command =>
sub {
$HELP->deiconify;
},
)->pack(qw/-side left -expand 0 -fill y/);
$quest->bind('<2>' => sub {
my (@register) = ('(X)', '(Y)', '(Z)', '(T)');
print "\n";
for (my $i = $#STACK; $i >= 0; $i--) {
print "stack+$i $register[$i] : '", $STACK[$i], "'\n";
}
});
$mw->Frame(
-background => $SILVER,
-width => 5,
-height => 25,
)->pack(qw/-side left -expand 0/);
# Create special Compound images for certain keys.
my $rolu = $mw->Compound;
my (@cargs) = (-foreground => $BLUE, -background => $GRAY);
$rolu->Text(-text => 'R', -foreground => $BLUE);
$rolu->Image(-image => $mw->Bitmap(-data => << 'END', @cargs));
#define up2_width 11
#define up2_height 12
static unsigned char up2_bits[] = {
0x00, 0x00, 0x20, 0x00, 0x70, 0x00, 0xf8, 0x00, 0xfc, 0x01, 0xfe, 0x03,
0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x00, 0x00,
};
END
my $rold = $mw->Compound;
@cargs = (-foreground => 'white', -background => $GRAY);
$rold->Text(-text => 'R', -foreground => 'white');
$rold->Image(-image => $mw->Bitmap(-data => << 'END', @cargs));
#define down2_width 11
#define down2_height 12
static unsigned char down2_bits[] = {
0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00,
0xfe, 0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00,
};
END
my $swap = $mw->Compound;
$swap->Text(-text => 'X', -foreground => 'white');
$swap->Image(-image => $mw->Bitmap(-data => << 'END', @cargs));
#define swap_width 8
#define swap_height 15
static unsigned char swap_bits[] = {
0x00, 0x00, 0x00, 0x06, 0x18, 0x60, 0x18, 0x06, 0x00, 0x60, 0x18, 0x06,
0x18, 0x60, 0x00, };
END
$swap->Text(-text => 'Y', -foreground => 'white');
# Build the first 2 rows of the calculator, 10 calculator keys per row.
my $dv = sub {$_[1] / $_[0]}; # division
my $xr = sub {$_[1] ^ $_[0]}; # exclusive OR
my $dd = sub {$_[1] / $_[0]}; # double divide
my $sq = sub {sqrt $_[0]}; # square root
my $rp = sub {1 / $_[0]}; # reciprocal
my $ml = sub {$_[1] * $_[0]}; # multiplication
my $an = sub {$_[1] & $_[0]}; # AND
my $dm = sub {$_[1] * $_[0]}; # double multiply
build_button_rows $frame1, [
[
['A', 'SL', 'LJ', $GRAY, \&err],
['B', 'SR', 'ASR', $GRAY, \&err],
['C', 'RL', 'RLC', $GRAY, \&err],
['D', 'RR', 'RRC', $GRAY, \&err],
['E', 'RLn', 'RLCn', $GRAY, \&err],
['F', 'RRn', 'RRCn', $GRAY, \&err],
['7', 'MASKL', '#B', $GRAY, [\&key, '7']],
['8', 'MASKR', 'ABS', $GRAY, [\&key, '8']],
['9', 'RMD', 'DBLR', $GRAY, [\&key, '9']],
['/', 'XOR', 'DBL/', $GRAY, [\&math3, $dv, $xr, $dd]],
],
[
['GSB', 'x><(i)', 'RTN', $GRAY, \&err],
['GTO', 'x><I', 'LBL', $GRAY, \&err],
['HEX', 'Show', 'DSZ', $GRAY, \&err],
['DEC', 'Show', 'ISZ', $GRAY, \&err],
['OCT', 'Show', 'sqrt', $GRAY, [\&gmath, $sq]],
['BIN', 'Show', '1/x', $GRAY, [\&gmath, $rp]],
['4', 'SB', 'SF', $GRAY, [\&key, '4']],
['5', 'CB', 'CF', $GRAY, [\&key, '5']],
['6', 'B?', 'F?', $GRAY, [\&key, '6']],
['*', 'AND', 'DBLx', $GRAY, [\&math3, $ml, $an, $dm]],
],
];
# Build the leftmost 5 calculator keys of the last 2 rows.
build_button_rows $frame2, [
[
['R/S', '(i)', 'p/r', $GRAY, \&err],
['SST', 'I', 'BST', $GRAY, \&err],
[$rold, 'cPRGM', $rolu, $GRAY, \&roll_stack],
[$swap, 'cREG', 'PSE', $GRAY, \&swapxy],
['BSP', 'cPREFIX', 'CLx', $GRAY, \&bspclrx],
],
[
['ON', '', '', $GRAY, \&on],
['f', '', '', $ORANGE, \&f],
['g', '', '', $BLUE, \&g],
['STO', 'WSIZE', '<', $GRAY, \&err],
['RCL', 'FLOAT', '>', $GRAY, \&err],
],
];
# The 2 column high ENTER key divides the last 2 rows of calculator keys.
my $enter = $frame0->Key(
-topl => 'WINDOW',
-butl => "E\nN\nT\nE\nR",
-botl => 'LSTx',
-background => $GRAY,
-command => \&enter,
-height => 6,
);
$enter->pack(qw/-side left -expand 1 -fill both/);
# Build the rightmost 4 calculator keys of the last two rows.
my $sb = sub {$_[1] - $_[0]}; # subtraction
my $ad = sub {$_[1] + $_[0]}; # addition
my $io = sub {$_[1] | $_[0]}; # inclusive OR
build_button_rows $frame3, [
[
['1', '1\'S', 'X<=y', $GRAY, [\&key, '1']],
['2', '2\'S', 'x<0', $GRAY, [\&key, '2']],
['3', 'UNSGN', 'x>y', $GRAY, [\&key, '3']],
['-', 'NOT', 'x>0', $GRAY, [\&math3, $sb, undef, undef]],
],
[
['0', 'MEM', 'x!=y', $GRAY, [\&key, '0']],
['.', 'STATUS', 'x!=0', $GRAY, [\&key, '.']],
['CHS', 'EEX', 'x=y', $GRAY, \&chs],
['+', 'OR', 'x=0', $GRAY, [\&math3, $ad, $io, undef]],
],
];
# Now establish key bindings for the digits and common arithmetic
# operation, including keypad keys, delete, etcetera.
foreach my $key ( qw/0 1 2 3 4 5 6 7 8 9/ ) {
$mw->bind( "<Key-$key>" => [\&key, $key] );
$mw->bind( "<KP_$key>" => [\&key, $key] );
}
foreach my $key ( qw/period KP_Decimal/ ) {
$mw->bind( "<$key>" => [\&key, '.'] );
}
foreach my $key ( qw/Return KP_Enter/ ) {
$mw->bind( "<$key>" => \&enter );
}
foreach my $key ( qw/plus KP_Add/ ) {
$mw->bind( "<$key>" => [\&math3, $ad, $io, undef] );
}
foreach my $key ( qw/minus KP_Subtract/ ) {
$mw->bind( "<$key>" => [\&math3, $sb, undef, undef] );
}
foreach my $key ( qw/asterisk KP_Multiply/ ) {
$mw->bind( "<$key>" => [\&math3, $ml, $an, $dm] );
}
foreach my $key ( qw/slash KP_Divide/ ) {
$mw->bind( "<$key>" => [\&math3, $dv, $xr, $dd] );
}
$mw->bind( '<Delete>' => \&bspclrx );
$MAC_PB->set($MAC_PB_P = 90);
} # end build_calculator
sub build_help_window {
$MAC_PB->set($MAC_PB_P = 10);
$HELP = $mw->Toplevel(-tile => $mw->Photo(-file => 'hp16c-tile.gif'));
$HELP->withdraw;
$MAC_PB->set($MAC_PB_P = 15);
$HELP->title('HP 16C Help');
$HELP->protocol('WM_DELETE_WINDOW' => sub {});
$MAC_PB->set($MAC_PB_P = 20);
my $frame = $HELP->Frame->pack(qw/-padx 70 -pady 40/);
$frame->Button(
-text => 'Close',
-command => sub {$HELP->withdraw},
-background => $BLUE_DARKER,
-activebackground => $BLUE,
)->pack(qw/-expand 1 -fill both/);
$frame->Label(
-text => '? <B2> prints the stack.',
)->pack(qw/-expand 1 -fill both/);
$MAC_PB->set($MAC_PB_P = 25);
$frame->Label(-image => $mw->Photo(-file => 'hp16c-help.gif'))->pack;
$MAC_PB->set($MAC_PB_P = 30);
$frame->Label(
-text => ' ',
)->pack(qw/-expand 1 -fill both/);
$MAC_PB->set($MAC_PB_P = 35);
} # end build_help_window
sub splash {
my $splash = $mw->Splashscreen(-milliseconds => 3000);
$splash->Label(-text => 'Building your HP 16C ...', -bg => $BLUE)->
pack(qw/-fill both -expand 1/);
$MAC_PB = $splash->MacProgressBar(-width => 300);
$MAC_PB->pack(qw/-fill both -expand 1/);
$splash->Label(-image => $mw->Photo(-file => 'hp16c-splash.gif'))->pack;
$splash->bindDump;
return $splash;
} # end_splash
# Calculator key processors.
sub bspclrx {
return unless $ONOFF;
if ($F_PRESSED) {
$mw->bell;
end;
return;
}
if ($G_PRESSED) { # clrX
$STACK[0] = 0;
$CLRX = 1;
$PUSHX = 0;
} else {
if (length($STACK[0]) <= 2) { # BKSP
$STACK[0] = 0;
$CLRX = 1;
$PUSHX = 0;
} else {
chop $STACK[0];
}
}
end;
}
sub chs { # change sign
my $s = substr($STACK[0], 0, 1);
substr($STACK[0], 0, 1) = ($s eq '-') ? ' ' : '-';
end;
}
sub end { # key cleanup
$F_PRESSED = $G_PRESSED = 0;
$XV = $STACK[0];
}
sub enter { # enter key
unshift @STACK, $STACK[0];
$#STACK = $STACKM if $#STACK > $STACKM;
$CLRX = 1;
$PUSHX = 0;
end;
}
sub err {$mw->bell if $ONOFF} # error
sub f {$F_PRESSED = 1}; # F key
sub g {$G_PRESSED = 1}; # G key
sub gmath { # G key arithmetic operations
# gmath( ) expects one code reference to an anonymous subroutine, which
# expects one argument, X from the RPN stack.
if (not $G_PRESSED) {
$mw->bell;
end;
return;
}
$STACK[0] = &{$_[0]}($STACK[0]);
$STACK[0] = " $STACK[0]" if substr($STACK[0], 0, 1) ne '-';
$CLRX = $PUSHX = 1;
end;
}
sub hpshift { # empty HP stack
$#STACK = $STACKM if $#STACK > $STACKM;
my $v = shift @STACK;
$STACK[$STACKM] = $STACK[$STACKM - 1] if $#STACK == ($STACKM - 1);
end;
return $v;
}
sub key { # process generic key clicks
shift if ref $_[0]; # toss bind( ) object
my $key = $_[0];
return unless $ONOFF;
if ($F_PRESSED or $G_PRESSED) {
$mw->bell;
end;
return;
}
&enter if $PUSHX;
$STACK[0] = ' ' if $CLRX;
$STACK[0] .= $key;
$CLRX = $PUSHX = 0;
end;
} # end key
sub math3 { # tri-arithmetic keys
# math3( ) expects three code references to anonymous subroutines, each
# of which expects two arguments, X and Y from the RPN stack.
#
# $_[0] = normal button press
# $_[1] = "f" qualified button press
# $_[2] = "g" qualified button press
shift if ref $_[0]; # toss bind( ) object
my $math = $_[0];
$math = $_[1] if $F_PRESSED;
$math = $_[2] if $G_PRESSED;
if (not defined $math) {
$mw->bell;
end;
return;
}
my $x = &hpshift;
my $y = $STACK[0];
$STACK[0] = &{$math}($x, $y);
$STACK[0] = " $STACK[0]" if substr($STACK[0], 0, 1) ne '-';
$CLRX = $PUSHX = 1;
end;
}
sub on { # power on/off
if ($ONOFF) {
$ONOFF = 0;
if (open(RC, ">$RCFILE")) {
foreach (reverse @STACK) {
print RC "$_\n";
}
close RC;
}
end;
$XV = '';
} else {
$ONOFF = 1;
if (open(RC, $RCFILE)) {
@STACK = ( ) if -s $RCFILE;
while ($_ = <RC>) {
chomp;
unshift @STACK, $_;
}
close RC;
}
$CLRX = $PUSHX = 1;
end;
}
} # end on
sub roll_stack {
return unless $ONOFF;
if ($F_PRESSED) {
$mw->bell;
end;
return;
}
if ($G_PRESSED) {
unshift @STACK, pop @STACK; # roll stack up
} else {
push @STACK, shift @STACK; # roll stack down
}
end;
}
sub swapxy {
return unless $ONOFF;
if ($F_PRESSED or $G_PRESSED) {
$mw->bell;
end;
return;
}
(@STACK[0, 1]) = (@STACK[1, 0]);
end;
} |  | |
| C.6. Tk::Trace |  | C.8. Tk::MacProgressBar |
Copyright © 2002 O'Reilly & Associates. All rights reserved.