Book HomeMastering Perl/TkSearch this book

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;
}


Library Navigation Links

Copyright © 2002 O'Reilly & Associates. All rights reserved.