2004-08-02 SRIV weeCalc: a proof of concept calculator app for
weeDesk. I know the name was reserved for a speadsheet app, but until someone takes 10 minutes to code one up, this will be weeCalc.
Background: This app was originally a Visual Tcl project that I coded for my linux iPaq, hence the dimensions. The buttons are big enough to be easily operated by my index fingers. I gutted all the Vtcl crap out, Still needs a lot of reformatting to make it readable, so dont complain about its ugliness. This calculator script runs fine from wish or tclkit. I use it as my everyday calculator app.
Here's a screenshot:
01Nov04
SRIV Updated to version 1.3 WeeCalc to handle octal and binary numbers! Get calc.tk from
http://www.sr-tech.com/testing/calc.tk
and save this file as calc.tk in the same directory as
weeDesk. Then, add these lines to the end of weedesk.tcl:
#start of weeCalc code
pack forget .win1.t
set base .win1
source calc.tk
bind .win1.ent38 <ButtonPress-1> "winSelect .win1"
07oct04
jcw - Steve, is your identcl-as-a-weeApp code public? It could be nice under
GooWee, what it needs for that is a way to use an arbitrary frame as "toplevel".
Larry Smith Latest version, courtesy of
Michael Doyle and
Eolas.
#
# H E W L E T T · P A C K A R D 15C
#
# A simulator written in Tcl/TK
#
# © 1997-2005 Torsten Manz
# extensive mods by Larry Smith 1/20/06
#
# ------------------------------------------------------------------------------
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or any later version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# ------------------------------------------------------------------------------
package require Tk
# ------------------------------------------------------------------------------
# Hide window until everything is ready
# wm withdraw .
### LCD NUMBER DISPLAY ENGINE ###
package require Tk
# hex segment
set dx 2
set 2dx 4
set dy 2
set 2dy 4
set seglen 8
set dheight [expr 2*$seglen+4*$dy]
set dwidth 25
set digits 11
set coord1 "0 0"
set coord2 "$dx -$dy"
set coord3 "[expr $dx+$seglen] -$dy"
set coord4 "[expr $2dx+$seglen] 0"
set coord5 "[expr $dx+$seglen] $dy"
set coord6 "$dx $dy"
set horseg "$coord1 $coord2 $coord3 $coord4 $coord5 $coord6"
set coord1 "0 0"
set coord2 "$dx -$dy"
set coord3 "$2dx 0"
set coord4 "$2dx $seglen"
set coord5 "$dx [expr $seglen+$dy]"
set coord6 "0 $seglen"
set verseg "$coord1 $coord2 $coord3 $coord4 $coord5 $coord6"
proc getseg { xoffset yoffset isHorizontal } {
global horseg verseg dx dx 2dx 2dy seglen
set xoffset [ expr $xoffset ]
set yoffset [ expr $yoffset ]
if $isHorizontal { set result $horseg } else { set result $verseg }
for {set j 0 } { $j < 12 } { incr j } {
set result [ lreplace $result $j $j [ expr [lindex $result $j] + $xoffset] ]
incr j
set result [ lreplace $result $j $j [ expr [lindex $result $j] + $yoffset] ]
}
return $result
}
# The shapes of individual elements of a digit
set lcdshape(a) [ getseg 0 0 0 ]
set lcdshape(b) [ getseg $dx -$dy 1 ]
set lcdshape(c) [ getseg $2dx+$seglen 0 0 ]
set lcdshape(d) [ getseg $2dx+$seglen $2dy+$seglen 0 ]
set lcdshape(e) [ getseg $dx 3*$dy+2*$seglen 1 ]
set lcdshape(f) [ getseg 0 $2dy+$seglen 0 ]
set lcdshape(g) [ getseg $dx $dy+$seglen 1 ]
set lcdshape(h) {18 22 18 28 23 28 23 22 }
set lcdshape(i) {18 28 23 28 16 34}
# Which elements are turned on for a given digit?
array set llcd {
0 {a b c d e f}
1 {c d}
2 {b c e f g}
3 {b c d e g}
4 {a c d g}
5 {a b d e g}
6 {a b d e f g}
7 {b c d}
8 {a b c d e f g}
9 {a b c d e g}
A {a b c d f g}
B {a d e f g}
C {a b e f}
D {c d e f g}
E {a b e f g}
F {a b f g}
- {g}
. {h}
, {h i}
r {a b}
u {a g c}
n {a b c}
i { c }
g {a b c d e g}
e {a b e f g}
o {a b c g}
{ } {}
}
# Displays a decimal str using LCD digits in the top-left of the canvas
set eurostyle 0
proc showLCD { n1 n2 op } {
global curdisp llcd lcdshape eurostyle dwidth
set colors {#929292 #000000 #929292 #A2A2A2}
set lcdoffset 0
.display delete lcd
foreach {onRim onFill offRim offFill} $colors {break}
set len [ string length $curdisp ]
for { set j 0 } { $j < $len } { incr j } {
set glyph [ string index $curdisp $j ]
set next [ string index $curdisp [ expr $j+1 ] ]
foreach symbol {a b c d e f g} {
if {[lsearch $llcd($glyph) $symbol] != -1} {
.display move [.display create polygon $lcdshape($symbol) -tags lcd \
-outline $onRim -fill $onFill] $lcdoffset 8
} else {
.display move [.display create polygon $lcdshape($symbol) -tags lcd \
-outline $offRim -fill $offFill] $lcdoffset 8
}
}
if { $next eq "." } {
.display move [.display create polygon $lcdshape(h) -tags lcd \
-outline $onRim -fill $onFill] $lcdoffset 0
if $eurostyle {
.display move [.display create polygon $lcdshape(i) -tags lcd \
-outline $onRim -fill $onFill] $lcdoffset 0
}
incr j
} elseif { $next eq "," } {
.display move [.display create polygon $lcdshape(h) -tags lcd \
-outline $onRim -fill $onFill] $lcdoffset 0
if !$eurostyle {
.display move [.display create polygon $lcdshape(i) -tags lcd \
-outline $onRim -fill $onFill] $lcdoffset 0
}
incr j
}
incr lcdoffset $dwidth
}
update
}
# ------------------------------------------------------------------------------
# Application data: All non persistent parameters
array set APPDATA {
title "INTELLIGENCE QUOTIENT 15C"
titlewide "I N T E L L I G E N C E Q U O T I E N T 1 5 C"
version 1.2.02
copyright "COPYRIGHT \u00A9 1997-2005, Torsten Manz, et al"
filetypes {{"IQ-15C Programs" {.15c}} {"Text files" {.txt}}}
}
set APPDATA(SerialNo) "4537G0[string map {. {}} $APPDATA(version)]"
# ------------------------------------------------------------------------------
# Check on required minimum Tcl/TK version and font
option add *Dialog.msg.font "Helvetica 10" userDefault
option add *Dialog.msg.wrapLength 600 userDefault
if {$tk_version < "8.0"} {
puts $APPDATA(titlewide)
puts "ERROR: This program requires Tcl/Tk 8.4 or higher."
exit
} elseif {$tk_version < "8.4"} {
tk_messageBox -type ok -icon error -default ok -title $APPDATA(titlewide) \
-message "This program requires Tcl/Tk 8.4 or higher."
exit
}
# ------------------------------------------------------------------------------
# Default program settings
array set HP15 {
breakstomenu 1
browser ""
clpbrdc 0
dataregs 19
delay 100
flash 200
freebytes 0
gsbmax 7
maxval 9.999999999e99
mnemonics 1
pause 1000
prgmcoloured 1
prgmmenubreak 30
prgmname ""
prgmregsfree 46
prgmregsused 0
prgmstounicode 1
saveonexit 1
strictHP15 1
totregs 65
}
# Used by preferences dialogue box to hold changed values until Ok or Apply.
array set hp15tmp {}
# ------------------------------------------------------------------------------
# Platform independent interface settings
array set LAYOUT {
display #A2A699
display_outer_frame #C0C0C0
display_inner_frame #D9DEDD
keypad_bg #484848
button_bg #434343
keypad_frame #E0E0E0
fbutton_bg #FFFF00
gbutton_bg #BBBBFF
BtnWidth 5
BtnPadX 1
BtnPadY 5
}
# display_outer_frame #F1F6F5
# Predefined, well adjusted font sets
set FONTSET {
{ {"unix" "UNIX Standard fonts, small" 70 80} {
FnDisplay "{Sans} 25"
FnStatus "Helvetica 8"
FnButton "Helvetica 11 bold"
FnEnter "Helvetica 11 bold"
FnFGBtn "Helvetica 9"
FnBrand "{Bitstream Vera Sans} 8"
FnLogo1 "{Chancery} 18"
FnLogo2 "{Sans} 12 bold"
FnMenu "{Courier} 12 bold"
}}
{ {"unix" "UNIX Standard fonts" 70 80} {
FnDisplay "{Sans} 29"
FnStatus "Helvetica 9"
FnButton "Helvetica 12 bold"
FnEnter "Helvetica 12 bold"
FnFGBtn "Helvetica 10"
FnBrand "Helvetica 11 bold"
FnLogo1 "{Chancery} 18"
FnLogo2 "{Sans} 12 bold"
FnMenu "{Courier} 12 bold"
}}
{ {"unix" "Microsoft fonts" 70 80} {
FnDisplay "{Sans} 28"
FnStatus "Arial 9"
FnButton "Arial 12 bold"
FnEnter "Arial 11 bold"
FnFGBtn "{Microsoft Sans Serif} 9"
FnBrand "Tahoma 9"
FnLogo1 "{Chancery} 18"
FnLogo2 "{Sans} 12 bold"
FnMenu "{Courier New} 12 bold"
}}
{ {"unix" "UNIX standard fonts, small" 81 135} {
FnDisplay "{Sans} 24"
FnStatus "Helvetica 8"
FnButton "Helvetica 10 bold"
FnEnter "Helvetica 10 bold"
FnFGBtn "Helvetica 8"
FnBrand "Helvetica 9 bold"
FnLogo1 "{Chancery} 18"
FnLogo2 "{Sans} 10 bold"
FnMenu "{Courier} 10 bold"
}}
{ {"unix" "UNIX standard fonts" 81 135} {
FnDisplay "{Sans} 26"
FnStatus "Helvetica 9"
FnButton "Helvetica 12 bold"
FnEnter "Helvetica 11 bold"
FnFGBtn "Helvetica 9"
FnBrand "Helvetica 9"
FnLogo1 "{Chancery} 18"
FnLogo2 "{Sans} 10 bold"
FnMenu "{Courier} 12 bold"
}}
{ {"unix" "Microsoft fonts, small" 81 135} {
FnDisplay "{Sans} 22"
FnStatus "{Microsoft Sans Serif} 7"
FnButton "Arial 9 bold"
FnEnter "Arial 9 bold"
FnFGBtn "Arial 8"
FnBrand "Arial 8 bold"
FnLogo1 "{Chancery} 18"
FnLogo2 "{Sans} 10 bold"
FnMenu "{Courier New} 12 bold"
}}
{ {"unix" "Microsoft fonts" 81 135} {
FnDisplay "{Sans} 26"
FnStatus "{Microsoft Sans Serif} 8"
FnButton "Arial 12 bold"
FnEnter "Arial 10 bold"
FnFGBtn "Arial 9 bold"
FnBrand "Arial 9 bold"
FnLogo1 "{Chancery} 18"
FnLogo2 "{Sans} 10 bold"
FnMenu "{Courier New} 12 bold"
}}
{ {"windows" "Microsoft fonts, small" 91 135} {
FnDisplay "{Sans} 22"
FnStatus "{Microsoft Small Fonts} 6"
FnButton "Arial 9 bold"
FnEnter "Arial 8 bold"
FnFGBtn "{Microsoft Sans Serif} 6"
FnBrand "Arial 7 bold"
FnLogo1 "{Chancery} 12"
FnLogo2 "{Sans} 9 bold"
FnMenu "{Courier New} 10 bold"
}}
{ {"windows" "Microsoft fonts" 91 135} {
FnDisplay "{Sans} 23"
FnStatus "{Microsoft Sans Serif} 7"
FnButton "Arial 10 bold"
FnEnter "Arial 9 bold"
FnFGBtn "{Microsoft Sans Serif} 7"
FnBrand "Arial 8 bold"
FnLogo1 "{Chancery} 12"
FnLogo2 "{Sans} 9 bold"
FnMenu "{Courier New} 10 bold"
}}
{ {"windows" "URW fonts, small" 91 135} {
FnDisplay "{Sans} 17"
FnStatus "{Nimbus Sans L} 7"
FnButton "{Nimbus Sans L} 9 bold"
FnEnter "{Nimbus Sans L} 8 bold"
FnFGBtn "{Bitstream Vera Sans} 7"
FnBrand "{Nimbus Sans L} 7 bold"
FnLogo1 "{Chancery} 18"
FnLogo2 "{Sans} 9 bold"
FnMenu "{Courier New} 10 bold"
}}
}
# Labels for preferences. Used both in dialogue and message boxes.
array set PREFTEXT {
breakstomenu "Two column storage menu"
browser "Help file browser"
clpbrdc "Use C locale for clipboard"
delay {Delay value [ms]}
fonthint \
"Changes to font settings take effect when you\nrestart the Simulator."
frm_browser "Help file browser"
frm_fontset "Font settings"
frm_os "System settings"
frm_simulator "Simulator settings"
mnemonics "Program mnemonics"
pause {Pause length [ms]}
prgmcoloured "Coloured program menu"
prgmmenubreak "Lines per column in program menu"
prgmstounicode "Encode programs in UNICODE"
saveonexit "Save memory on exit"
strictHP15 "Strict HP-15C behaviour"
}
# ------------------------------------------------------------------------------
# Platform specific settings
switch $::tcl_platform(platform) {
windows {
set APPDATA(memfile) "HP-15C.mem"
set APPDATA(exetypes) {{"Executable files" {.exe}}}
set APPDATA(browserlist) {mozilla firefox netscape opera start iexplore hh}
switch -glob "$::tcl_platform(os) $::tcl_platform(osVersion)" {
"Windows 95 *" {set APPDATA(HOME) $env(windir)}
"Windows NT 4.0" {set APPDATA(HOME) $env(homedrive)$env(homepath)}
"Windows NT 5.*" {set APPDATA(HOME) $env(APPDATA)}
-- { tk_messageBox -type ok -icon error -default ok \
-title $APPDATA(titlewide) -message \
"$::tcl_platform(os) $::tcl_platform(osVersion) is not supported."
}
}
set HP15(prgmdir) $APPDATA(HOME)
set HP15(fontset) 8
}
unix {
set APPDATA(memfile) ".hp-15c.mem"
set APPDATA(exetypes) {{"All files" {*}}}
set APPDATA(browserlist) {mozilla firefox netscape opera konqueror}
set APPDATA(HOME) $env(HOME)
set HP15(fontset) [expr round([tk scaling]*72) < 81 ? 1 : 4]
set HP15(prgmdir) $APPDATA(HOME)
}
-- {
tk_messageBox -type ok -icon error -default ok \
-title $APPDATA(titlewide) \
-message "Platform '$::tcl_platform(platform)' not supported."
}
}
# ------------------------------------------------------------------------------
# Initialize processor, stack and storage registers
set PI [expr acos(0)*2.0]
array set status {
f 0
g 0
user 0
BEGIN 0
RAD {}
DMY 0
PRGM 0
integrate 0
solve 0
num 1
liftlock 1
dispmode FIX
dispprec 3
comma ,
dot .
error 0
seed 0
}
# Must do this outside of "array set" to become evaluated
set status(RADfactor) [expr $PI/180.0]
# During execution two additional registers are added to the stack:
# s: general scratchpad register that stores the last operand
# u: used by helper functions in complex mode
array set stack {
x 0.0
y 0.0
z 0.0
t 0.0
LSTx 0.0
}
array set istack {
x 0.0
y 0.0
z 0.0
t 0.0
LSTx 0.0
}
array set prgstat {
curline 0
running 0
interrupt 0
rtnadr {0}
maxiter {10000}
}
set PRGM {""}
# Flags
array set FLAG { 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 9 0 }
# Test menu labels. Also used for mnemonics.
set TEST { "x \u2260 0" "x > 0" "x < 0" "x \u2265 0" "x \u2264 0" "x = y" \
"x \u2260 y" "x > y" "x < y" "x \u2265 y" "x \u2264 y" "x = 0" }
# ------------------------------------------------------------------------------
# Global program control variables
set curdisp 0
set keyseq ""
set isseq 0
# ------------------------------------------------------------------------------
# List of HP-15C keys
# Key definitions
# Each key definition consists of 10 elements:
# row column : Row [1-4] and column [1-10] on the key pad
# rowspan : Numbers of rows a key spans (normally 1 but 2 for ENTER)
# key-code : Normally row+column, but numeric keys return number
# f-label label g-label : The keys labels. Encoded in UNICODE.
# f-binding binding g-binding : List of X11-keysyms bound to a key
#
set HP15_KEYS {
{ 1 1 1 11 A \u221ax x\u00B2 {Alt-a} {q} {Alt-x} }
{ 1 2 1 12 B e\u2191x LN {Alt-b} {e} {Alt-n} }
{ 1 3 1 13 C 10\u2191x LOG {Alt-c} {x} {Alt-g} }
{ 1 4 1 14 D y\u2191x % {Alt-d} {y} {percent} }
{ 1 5 1 15 E 1/x \u0394% {Alt-e} {Alt-slash backslash ssharp} {d} }
{ 1 6 1 16 MATRIX CHS ABS {} {Alt-minus} {bar brokenbar} }
{ 1 7 1 7 FIX 7 DEG {} {7 KP_7} {} }
{ 1 8 1 8 SCI 8 RAD {} {8 KP_8} {} }
{ 1 9 1 9 ENG 9 GRD {} {9 KP_9} {} }
{ 1 10 1 10 SOLVE \u00F7 x\u2264y {} {slash KP_Divide} {} }
{ 2 1 1 21 LBL SST BST {F8} {} {} }
{ 2 2 1 22 HYP GTO HYP\u002D\u00B9 {h} {F2} {Alt-h} }
{ 2 3 1 23 DIM SIN SIN\u002D\u00B9 {} {s} {} }
{ 2 4 1 24 (i) COS COS\u002D\u00B9 {} {c} {} }
{ 2 5 1 25 I TAN TAN\u002D\u00B9 {I j} {t} {} }
{ 2 6 1 26 RESULT EEX \u03C0 {} {E} {p} }
{ 2 7 1 4 x\u2194? 4 SF {Alt-less Alt-greater} {4 KP_4} {} }
{ 2 8 1 5 DSE 5 CF {} {5 KP_5} {} }
{ 2 9 1 6 ISG 6 F? {} {6 KP_6} {} }
{ 2 10 1 20 \u222Bxy \u00D7 x=0 {} {asterisk KP_Multiply} {} }
{ 3 1 1 31 PSE R/S P/R {F6} {F5} {F9} }
{ 3 2 1 32 \u2211 GSB RTN {} {F3} {F4} }
{ 3 3 1 33 PRGM R\u2193 R\u2191 {} {Down} {Up} }
{ 3 4 1 34 REG x\u2194y RND {} {less greater} {} }
{ 3 5 1 35 PREFIX \u2190 CLx {} {BackSpace} {Escape} }
{ 3 6 2 36 "RAN #" ENTER LSTx {numbersign} {Return KP_Enter} {} }
{ 3 7 1 1 \u2192R 1 \u2192P {} {1 KP_1} {} }
{ 3 8 1 2 \u2192H.MS 2 \u2192H {} {2 KP_2} {} }
{ 3 9 1 3 \u2192RAD 3 \u2192DEG {} {3 KP_3} {} }
{ 3 10 1 30 Re\u2194Im - TEST {Tab} {minus KP_Subtract} {} }
{ 4 1 1 41 "" ON "" {} {} {} }
{ 4 2 1 42 "" f "" {} {} {} }
{ 4 3 1 43 "" g "" {} {} {} }
{ 4 4 1 44 FRAC STO INT {} m {} }
{ 4 5 1 45 USER RCL MEM {u} r {} }
{ 4 7 1 0 x! 0 x {exclam} {0 KP_0} {} }
{ 4 8 1 48 \u0177,r . s {} {comma period KP_Decimal} {} }
{ 4 9 1 49 L.R. \u2211+ \u2211- {} {Insert} {Delete} }
{ 4 10 1 40 Py,x + Cy,x {} {plus KP_Add} {} }
}
# HP-15C Key sequence, corresponding functions and function attributes
# Key sequence: A regular expression describing a set of key sequences
# Function name: The Tcl function.
# Attributes (0|1):
# LSTx: Operand is saved in the LSTx register.
# End input: Function terminates input. Thus we have a number.
# Programmable: Function is programmable.
set HP15_KEY_FUNCS {
{
{ 0 "func_digit 0" 0 0 1}
{ 1 "func_digit 1" 0 0 1}
{ 2 "func_digit 2" 0 0 1}
{ 3 "func_digit 3" 0 0 1}
{ 4 "func_digit 4" 0 0 1}
{ 5 "func_digit 5" 0 0 1}
{ 6 "func_digit 6" 0 0 1}
{ 7 "func_digit 7" 0 0 1}
{ 8 "func_digit 8" 0 0 1}
{ 9 "func_digit 9" 0 0 1}
{10 "func_div" 1 1 1}
{11 "func_sqrt" 1 1 1}
{12 "func_exp" 1 1 1}
{13 "func_10powx" 1 1 1}
{14 "func_ypowx" 1 1 1}
{15 "func_inv" 1 1 1}
{16 "func_chs" 0 0 1}
{20 "func_mult" 1 1 1}
{21 "func_sst" 0 0 0}
{22_([0-9]) "func_gto " 0 1 1}
{22_1([1-5]) "func_gto -" 0 1 1}
{22_25 "func_gto I" 0 1 1}
{22_48_([0-9]) "func_gto 1" 0 1 1}
{22_16_([0-9]) "func_gto_chs " 0 0 0}
{23 "func_trign sin" 1 1 1}
{24 "func_trign cos" 1 1 1}
{25 "func_trign tan" 1 1 1}
{26 "func_digit e+0" 0 0 1}
{30 "func_minus" 1 1 1}
{31 "func_rs" 0 1 1}
{32_([0-9]) "func_gsb " 0 1 1}
{32_1([1-5]) "func_gsb -" 0 1 1}
{32_25 "func_gsb I" 0 1 1}
{32_48_([0-9]) "func_gsb 1" 0 1 1}
{33 "func_roll 1" 0 1 1}
{34 "func_xy" 0 1 1}
{35 "func_bs" 0 0 0}
{36 "func_enter" 0 1 1}
{40 "func_plus" 1 1 1}
{41 "func_on" 0 0 0}
{48 "func_digit ." 0 0 1}
{49 "func_sum_plus" 1 1 1}
} {
{42_0 "func_faculty" 1 1 1}
{42_1 "func_rectangular" 1 1 1}
{42_1([1-5]) "dispatch_key 32_1" 0 0 0}
{42_10_([0-9]) "func_solve " 0 1 1}
{42_10_1([1-5]) "func_solve -" 0 1 1}
{42_10_48_([0-9]) "func_solve 1" 0 1 1}
{42_16 "# not implemented" 0 0 0}
{42_2 "func_hms" 1 1 1}
{42_20_([0-9]) "func_integrate " 0 0 1}
{42_20_1([1-5]) "func_integrate -" 0 0 1}
{42_20_48_([0-9]) "func_integrate 1" 0 0 1}
{42_21_([0-9]) "func_label " 0 1 1}
{42_21_1([1-5]) "func_label " 0 1 1}
{42_21_48_([0-9]) "func_label 1" 0 1 1}
{42_22_23 "func_hyp sin" 1 1 1}
{42_22_24 "func_hyp cos" 1 1 1}
{42_22_25 "func_hyp tan" 1 1 1}
{42_23_1([1-5]) "# not implemented" 0 0 0}
{42_23_24 "func_dim_mem" 0 1 1}
{42_24 "func_i" 0 1 0}
{42_25 "func_I" 0 1 1}
{42_26 "# not implemented" 0 0 0}
{42_3 "func_rad" 1 1 1}
{42_30 "func_re_im" 0 1 1}
{42_31 "func_pse" 0 1 1}
{42_32 "func_clearsumregs" 0 1 1}
{42_33 "func_clearprgm" 0 1 0}
{42_34 "func_clearreg" 0 1 1}
{42_35 "func_prefix" 0 1 0}
{42_36 "func_random" 0 1 1}
{42_4_([0-9]) "func_xexchg " 0 1 1}
{42_4_24 "func_xexchg (i)" 0 1 1}
{42_4_25 "func_xexchg I" 0 1 1}
{42_4_48_([0-9]) "func_xexchg 1" 0 1 1}
{42_40 "func_Pyx" 1 1 1}
{42_44 "func_frac" 1 1 1}
{42_45 "set_status user" 0 1 0}
{42_48 "func_linexpolation" 0 1 1}
{42_49 "func_linreg" 0 1 1}
{42_5_([0-9]) "func_dse " 0 1 1}
{42_5_24 "func_dse (i)" 0 1 1}
{42_5_25 "func_dse I" 0 1 1}
{42_5_48_([0-9]) "func_dse 1" 0 1 1}
{42_6_([0-9]) "func_isg " 0 1 1}
{42_6_24 "func_isg (i)" 0 1 1}
{42_6_25 "func_isg I" 0 1 1}
{42_6_48_([0-9]) "func_isg 1" 0 1 1}
{42_7_([0-9]) "func_dsp_mode FIX " 0 1 1}
{42_7_25 "func_dsp_mode FIX I" 0 1 1}
{42_8_([0-9]) "func_dsp_mode SCI " 0 1 1}
{42_8_25 "func_dsp_mode SCI I" 0 1 1}
{42_9_([0-9]) "func_dsp_mode ENG " 0 1 1}
{42_9_25 "func_dsp_mode ENG I" 0 1 1}
} {
{43_0 "func_avg" 0 1 1}
{43_1 "func_polar" 1 1 1}
{43_10 "func_test 10" 0 1 1}
{43_11 "func_xpow2" 1 1 1}
{43_12 "func_ln" 1 1 1}
{43_13 "func_log10" 1 1 1}
{43_14 "func_percent" 1 1 1}
{43_15 "func_dpercent" 1 1 1}
{43_16 "func_abs" 1 1 1}
{43_2 "func_h" 1 1 1}
{43_20 "func_test 11" 0 1 1}
{43_21 "func_bst" 0 0 0}
{43_22_23 "func_ahyp sin" 1 1 1}
{43_22_24 "func_ahyp cos" 1 1 1}
{43_22_25 "func_ahyp tan" 1 1 1}
{43_23 "func_atrign sin" 1 1 1}
{43_24 "func_atrign cos" 1 1 1}
{43_25 "func_atrign tan" 1 1 1}
{43_26 "func_pi" 0 1 1}
{43_3 "func_deg" 1 1 1}
{43_30_([0-9]) "func_test " 0 1 1}
{43_31 "func_pr" 0 0 0}
{43_32 "func_rtn" 0 1 1}
{43_33 "func_roll 3" 0 1 1}
{43_34 "func_rnd" 1 1 1}
{43_35 "func_clx" 0 1 1}
{43_36 "func_lastx" 0 1 1}
{43_4_([0-9]) "func_sf " 0 1 1}
{43_4_25 "func_sf I" 0 1 1}
{43_40 "func_Cyx" 1 1 1}
{43_44 "func_int" 1 1 1}
{43_45 "func_mem" 0 1 0}
{43_48 "func_stddev" 0 1 1}
{43_49 "func_sum_minus" 1 1 1}
{43_5_([0-9]) "func_cf " 0 1 1}
{43_5_25 "func_cf I" 0 1 1}
{43_6_([0-9]) "func_Finq " 0 1 1}
{43_6_25 "func_Finq I" 0 1 1}
{43_7 "set_status DEG" 0 1 1}
{43_8 "set_status RAD" 0 1 1}
{43_9 "set_status GRAD" 0 1 1}
} {
{44_([0-9]) "func_sto " 0 1 1}
{44_25 "func_sto I" 0 1 1}
{44_24 "func_sto (i)" 0 1 1}
{44_48_([0-9]) "func_sto 1" 0 1 1}
{44_10_([0-9]) "func_sto_oper / " 0 1 1}
{44_10_24 "func_sto_oper / (i)" 0 1 1}
{44_10_25 "func_sto_oper / I" 0 1 1}
{44_10_48_([0-9]) "func_sto_oper / 1" 0 1 1}
{44_20_([0-9]) "func_sto_oper * " 0 1 1}
{44_20_24 "func_sto_oper * (i)" 0 1 1}
{44_20_25 "func_sto_oper * I" 0 1 1}
{44_20_48_([0-9]) "func_sto_oper * 1" 0 1 1}
{44_30_([0-9]) "func_sto_oper - " 0 1 1}
{44_30_24 "func_sto_oper - (i)" 0 1 1}
{44_30_25 "func_sto_oper - I" 0 1 1}
{44_30_48_([0-9]) "func_sto_oper - 1" 0 1 1}
{44_*36 "func_storandom" 0 1 1}
{44_40_([0-9]) "func_sto_oper + " 0 1 1}
{44_40_24 "func_sto_oper + (i)" 0 1 1}
{44_40_25 "func_sto_oper + I" 0 1 1}
{44_40_48_([0-9]) "func_sto_oper + 1" 0 1 1}
} {
{45_([0-9]) "func_rcl " 0 1 1}
{45_25 "func_rcl I" 0 1 1}
{45_24 "func_rcl (i)" 0 1 1}
{45_48_([0-9]) "func_rcl 1" 0 1 1}
{45_10_([0-9]) "func_rcl_oper / " 0 1 1}
{45_10_24 "func_rcl_oper / (i)" 0 1 1}
{45_10_25 "func_rcl_oper / I" 0 1 1}
{45_10_48_([0-9]) "func_rcl_oper / 1" 0 1 1}
{45_20_([0-9]) "func_rcl_oper * " 0 1 1}
{45_20_24 "func_rcl_oper * (i)" 0 1 1}
{45_20_25 "func_rcl_oper * I" 0 1 1}
{45_20_48_([0-9]) "func_rcl_oper * 1" 0 1 1}
{45_30_([0-9]) "func_rcl_oper - " 0 1 1}
{45_30_24 "func_rcl_oper - (i)" 0 1 1}
{45_30_25 "func_rcl_oper - I" 0 1 1}
{45_30_48_([0-9]) "func_rcl_oper - 1" 0 1 1}
{45_36 "func_rclrandom" 0 1 1}
{45_40_([0-9]) "func_rcl_oper + " 0 1 1}
{45_40_24 "func_rcl_oper + (i)" 0 1 1}
{45_40_25 "func_rcl_oper + I" 0 1 1}
{45_40_48_([0-9]) "func_rcl_oper + 1" 0 1 1}
{45_49 "func_rclsum" 0 1 1}
}
}
# ------------------------ End of variable definitions -------------------------
# ------------------------------------------------------------------------------
proc commify { num {sign ,} } {
if {$sign == "."} {regsub {[.]} $num "," num}
set trg "\\1$sign\\2\\3"
while {[regsub {^([-+ ]?[0-9]+)([0-9][0-9][0-9])([- ][0-9][0-9])?} \
$num $trg num]} {}
return $num
}
# ------------------------------------------------------------------------------
proc format_exponent { expo } {
if {$expo != ""} {
regsub {^([-+ ]?)0([1-9][0-9]?)} $expo {\1\2} expo
set expo [expr $expo >= 0 ? \" \" : \"-\"][format "%02d" [expr abs($expo)]]
}
return $expo
}
# ------------------------------------------------------------------------------
proc format_number { var } {
global HP15 status
set prec $status(dispprec)
set eexprecmax 6
set eex 1
# calculate mantissa and exponent parameters
set log [expr $var != 0 ? int(floor(log10(abs($var)))) : 0]
switch $status(dispmode) {
FIX {
if {$log >= -$prec && $log <= 9} {
set eex 0
if {$log+$prec > 9} {set prec [expr 9-$log]}
}
}
SCI {
# Nothing to do here
}
ENG {
set log [expr int($log/3)*3]
}
}
# format mantissa
append fmt "% ." $prec "f"
if {[expr $var >= $HP15(maxval)]} {
set mantissa " [string range $HP15(maxval) 0 7]"
} elseif {[expr $var <= -$HP15(maxval)]} {
set mantissa "-[string range $HP15(maxval) 0 7]"
} elseif {$eex == 1} {
set mantissa [format $fmt [expr $var/pow(10, $log)]]
if {$status(dispmode) != "ENG" && $mantissa >= 10.0 && $log < 99} {
incr log
set mantissa [format $fmt [expr $var/pow(10, $log)]]
}
set len [expr ($prec > $eexprecmax ? $eexprecmax : $prec)+2]
set mantissa [string range $mantissa 0 $len]
} else {
set mantissa [format $fmt $var]
}
if {[string first "." $mantissa] <= 0} {set mantissa "$mantissa."}
# format exponent
if {$eex == 0} {
set expo ""
} else {
set expo [format_exponent $log]
}
set filler [string repeat " " [expr 12-[string length "$mantissa$expo"]]]
# return concatenated number
return [commify "$mantissa$filler$expo" $status(dot)]
}
# ------------------------------------------------------------------------------
proc format_input { var } {
global status
regsub {(e[+-]$)} $var {\10} var
regexp {^([-+ ]?[.0-9]+)e?([+-][0-9]+)?} $var all mantissa expo
if {[string index $mantissa 0] != "-"} {set mantissa " $mantissa"}
set expo [format_exponent $expo]
set filler [string repeat " " \
[expr 11-[string length [string map {. ""} "$mantissa$expo"]]]]
return [commify [format "%s%s%s" $mantissa $filler $expo] $status(dot)]
}
# ------------------------------------------------------------------------------
proc format_prgm { lnum wid } {
global status PRGM
set kl [split [lindex $PRGM $lnum] "_"]
switch [llength $kl] {
1 -
2 {
set st [join $kl]
}
3 {
if {[lindex $kl 1] == 48} {
set st [format " %2d $status(comma)%1d" [lindex $kl 0] [lindex $kl 2]]
} else {
set st [format "%2d$status(dot)%2d$status(dot)%2d" \
[lindex $kl 0] [lindex $kl 1] [lindex $kl 2]]
}
}
4 {
set st [format "%2d$status(dot)%2d$status(dot) %2s" \
[lindex $kl 0] [lindex $kl 1] "$status(comma)[lindex $kl 3]"]
}
default {
set st ""
}
}
return "[format "%03d-%$wid\s" $lnum $st]"
}
# ------------------------------------------------------------------------------
proc error_handler { errinfo } {
global APPDATA HP15 FLAG stack istack status prgstat curdisp errorInfo errorCode
set errnum -1
set status(num) 1
if {[lindex $errinfo 0] == "ARITH"} {
switch [lindex $errinfo 1] {
IOVERFLOW -
OVERFLOW {
set stack(x) $HP15(maxval)
set istack(x) $HP15(maxval)
set FLAG(9) 1
show_x
}
NOVERFLOW {
set stack(x) -$HP15(maxval)
set istack(x) -$HP15(maxval)
set FLAG(9) 1
show_x
}
UNDERFLOW {
set stack(x) 0.0
show_x
}
INVALID -
default {
set errnum 0
}
}
} else {
switch [lindex $errinfo 0] {
SUM {
set errnum 2
}
INDEX {
set errnum 3
}
ADDRESS {
set errnum 4
}
RTN {
set errnum 5
}
FLAG {
set errnum 6
}
RECURSION {
set status(solve) 0
set status(integrate) 0
set errnum 7
}
SOLVE {
set errnum 8
}
DIM {
set errnum 10
}
INTERRUPT {
set prgstat(running) 0
set prgstat(interrupt) 0
show_x
}
FILEIO {
switch [lindex $errinfo 1] {
ECREATE {
set errmsg "Could not write file"
}
ENOENT {
set errmsg "No such file"
}
EOPEN {
set errmsg "Could not open file"
}
NONE -
EFMT {
set errmsg "Error parsing line [lindex $errinfo 3]"
}
INVCMD {
set errmsg "Invalid command in line [lindex $errinfo 3]"
}
default {
set errmsg "$errorInfo"
}
}
set errnum 98
tk_messageBox -type ok -icon error -default ok \
-title $APPDATA(titlewide) -message "$errmsg: [lindex $errinfo 2]"
}
default {
set errnum 99
tk_messageBox -type ok -icon error -default ok \
-title $APPDATA(titlewide) \
-message "Internal Tcl/Tk Error:\n$errorInfo"
set stack(x) 0.0
}
}
}
if {$errnum >= 0} {
set status(error) 1
set prgstat(running) 0
set curdisp " error [format "%2d" $errnum]"
}
}
# ------------------------------------------------------------------------------
proc show_x { args } {
global HP15 status stack curdisp
if {[catch {
if {abs($stack(x)) > 0.0 && abs($stack(x)) < 1E-99} {
error_handler {ARITH UNDERFLOW}
} elseif {[expr $stack(x) > $HP15(maxval)]} {
error_handler {ARITH OVERFLOW}
} elseif {[expr $stack(x) < -$HP15(maxval)]} {
error_handler {ARITH NOVERFLOW}
} else {
if {$status(num)} {
set curdisp [format_number $stack(x)]
} else {
set curdisp [format_input $stack(x)]
}
}
} errorCode]} {error_handler $errorCode}
}
set oldLCD ""
proc disp_flash { p1 p2 p3 } {
global curdisp oldLCD HP15 FLAG
set save $curdisp
if { $oldLCD == "" } {
set oldLCD $curdisp
set curdisp " "
update
} else {
set curdisp $oldLCD
set oldLCD ""
if !$FLAG(9) {
after $HP15(flash) disp_flash 1 1 1
}
}
}
# ------------------------------------------------------------------------------
proc mem_save {} {
global APPDATA HP15 status stack istack storage prgstat PRGM FLAG
set sepline "# [string repeat - 78]"
set fid [open "$APPDATA(HOME)/$APPDATA(memfile)" {RDWR CREAT TRUNC}]
puts $fid $sepline
puts $fid "# Tcl/Tk $APPDATA(title) memory file"
puts $fid "# The Simulator is $APPDATA(copyright)"
puts $fid "# Version $APPDATA(version)"
puts $fid "# Memory saved on [clock format [clock seconds] -format "%c"]"
puts $fid $sepline
puts $fid ""
foreach aa {HP15 status stack istack storage FLAG prgstat} {
puts $fid $sepline
puts $fid "# $aa"
puts $fid "array set $aa {"
foreach ii [lsort -dictionary [array names $aa]] {
puts $fid " $ii {[set ${aa}($ii)]}"
}
puts $fid "}\n"
}
puts $fid $sepline
puts $fid "# Program"
puts $fid "set PRGM {"
foreach ii $PRGM {
puts $fid " {$ii}"
}
puts $fid "}"
puts $fid $sepline
close $fid
}
# ------------------------------------------------------------------------------
proc mem_load {} {
global APPDATA HP15 status stack istack storage prgstat PRGM FLAG
set fnam "$APPDATA(HOME)/$APPDATA(memfile)"
if {[file exists $fnam]} {
if {[catch {source $fnam} err]} {
error_handler [list FILEIO EFMT $fnam $err]
}
}
# Refresh status line
set_status NIL
}
# ------------------------------------------------------------------------------
proc prgm_save {} {
global APPDATA HP15 PRGM
set sepline "# [string repeat - 44]"
set fnam [tk_getSaveFile -title "$APPDATA(title): Save program" \
-defaultextension ".15C" -filetypes $APPDATA(filetypes) \
-initialdir "$HP15(prgmdir)" -initialfile "$HP15(prgmname)"]
if {$fnam != ""} {
if {[catch {set fid [open $fnam {RDWR CREAT TRUNC}]}]} {
error_handler [list FILEIO ECREATE $fnam]
close $fid
return
}
if {$HP15(prgmstounicode)} {
puts -nonewline $fid "\377\376"
fconfigure $fid -encoding unicode
}
puts $fid $sepline
puts $fid "# Tcl/Tk $APPDATA(title) Simulator program"
puts $fid "# Created with version $APPDATA(version)"
puts $fid "$sepline\n"
for {set ii 0} {$ii < [llength $PRGM]} {incr ii} {
set seq ""
foreach cc [split [lindex $PRGM $ii] "_"] {
append seq [format {%3d} $cc]
}
puts $fid "[format " %03d {%12s } %s" $ii $seq \
[build_mnemonic [lindex $PRGM $ii] 0]]"
}
puts $fid "\n$sepline"
close $fid
set HP15(prgmdir) [file dirname $fnam]
set HP15(prgmname) [file tail $fnam]
}
}
# ------------------------------------------------------------------------------
proc prgm_open {} {
global APPDATA HP15 status prgstat PRGM errorCode
set fnam [tk_getOpenFile -initialdir "$HP15(prgmdir)" \
-title "$APPDATA(title): Open program" -defaultextension ".15C" \
-filetypes $APPDATA(filetypes)]
if {$fnam != ""} {
if {[catch {set fid [open "$fnam" {RDONLY}]}]} {
error_handler [list FILEIO EOPEN $fnam]
close $fid
return
}
# Check whether file is UNICODE or ASCII encoded
set unic [read $fid 2]
if {[string compare $unic "\377\376"] == 0 || \
[string index $unic 1] == "\000"} {
fconfigure $fid -encoding unicode
}
if {"$unic" != "\377\376"} {seek $fid 0}
set lcnt 0
set PRGMtmp {}
if {[catch {
while {[gets $fid curline] >= 0} {
incr lcnt
set curline [string trim $curline]
if {[string length $curline] > 0 && [string index $curline 0] != "#"} {
if {[regexp "\{(.*)\}" $curline all step] == 0} {
error "" "" {EFMT}
}
set step [string map {" " _ " " _} [string trim $step]]
if {[lookup_keyseq $step 1] == "" && [llength $PRGMtmp] > 0} {
error "" "" {INVCMD}
}
lappend PRGMtmp $step
unset step
}
}
}]} {
error_handler [list FILEIO $::errorCode $fnam $lcnt]
return
}
close $fid
# Insert empty step 000 if first step is not empty
if {[lindex $PRGMtmp 0] != ""} {set PRGMtmp [linsert $PRGMtmp 0 ""]}
set prgstat(curline) 0
set prgstat(rtnadr) {0}
set PRGM $PRGMtmp
if {$status(PRGM)} {show_curline}
set HP15(prgmdir) [file dirname $fnam]
set HP15(prgmname) [file tail $fnam]
}
}
# ------------------------------------------------------------------------------
proc clipboard_set { reg } {
global HP15 status stack
if {[string compare $::tcl_platform(platform) "unix"]} {
clipboard clear
if {$HP15(clpbrdc)} {
clipboard append $stack($reg)
} else {
clipboard append [string map ". $status(comma)" $stack($reg)]
}
} else {
selection handle -selection PRIMARY . clipboard_transfer
selection own -selection PRIMARY .
}
}
# ------------------------------------------------------------------------------
proc clipboard_transfer { offset maxchars } {
global HP15 status stack
if {$HP15(clpbrdc)} {
return $stack(x)
} else {
return [string map ". $status(comma)" $stack(x)]
}
}
# ----------------------------------------------------------------------------
proc clipboard_get {} {
global HP15 status stack
# On Windows only CLIPBOARD selection exists. On UNIX most applications use
# PRIMARY selection, some use CLIPBOARD (or both). We will check for both...
if {[catch {set clpbrd [selection get -selection PRIMARY]}]} {
catch {set clpbrd [selection get -selection CLIPBOARD]}
}
if {[info exists clpbrd]} {
if {$HP15(clpbrdc)} {
set clpbrd [string map {, ""} $clpbrd]
} else {
set clpbrd [string map {. "" , .} $clpbrd]
}
if {[string is double $clpbrd]} {
if {$status(num)} {lift}
set status(num) 1
set stack(x) $clpbrd
}
}
}
# ------------------------------------------------------------------------------
proc exchange_seps {} {
global status
set tmp $status(comma)
set status(comma) $status(dot)
set status(dot) $tmp
if {$status(PRGM)} {
show_curline
} else {
show_x
}
}
# ------------------------------------------------------------------------------
proc help { topic } {
global APPDATA HP15 argv0 errorInfo
switch $topic {
simulator {
# Differentiate between running from a starpack or from wish
if {[info exists starkit::topdir]} {
set helpdir [file dirname $starkit::topdir]
} else {
set helpdir [file dirname $argv0]
}
if {[string compare $helpdir "."] == 0} {set helpdir [pwd]}
set helpfile "$helpdir/doc/index.htm"
}
prgm {
set helpfile "$HP15(prgmdir)/[file rootname $HP15(prgmname)].htm"
}
}
catch {set helpfile [file nativename [lindex [glob "$helpfile*"] 0]]}
if {[string length $HP15(browser)] == 0} {
set msg "No help file browser configured.\nSee Preferences dialogue box."
preferences
} elseif {$topic == "prgm" && $HP15(prgmname) == ""} {
set msg "No help file available or\nno name given for current program."
} elseif {![file exists $helpfile]} {
set msg "Help file not found:\n$helpfile"
}
if {[info exists msg]} {
tk_messageBox -type ok -icon error -default ok \
-title $APPDATA(titlewide) -message $msg
if [winfo exists .prefs] {focus .prefs}
} else {
if {[catch {eval exec $HP15(browser) [list $helpfile] &} exerr]} {
tk_messageBox -type ok -icon error -default ok \
-title $APPDATA(titlewide) \
-message "Could not display help file:\n$exerr"
}
}
}
# ------------------------------------------------------------------------------
proc show_on_options { trigger } {
global LAYOUT status
if {[winfo exists .onm]} {destroy .onm}
menu .onm -tearoff 0 -title "Options" -font $LAYOUT(FnMenu)
.onm add command -label "Open program\u2026" -underline 0 \
-command "prgm_open"
.onm add command -label "Save program\u2026" -underline 0 \
-command "prgm_save"
.onm add separator
.onm add command -label "Save memory" -underline 5 -command "mem_save"
.onm add command -label "Load memory" -underline 0 -command "mem_load"
if {$status(PRGM)} {
set st disabled
} else {
set st normal
}
.onm add command -label "Clear all" -underline 0 -command "clearall" \
-state $st
.onm add separator
.onm add command \
-label "Radix: (.) or (,)" -underline 0 -command "exchange_seps"
.onm add command -label "Preferences\u2026" -underline 0 \
-command "preferences"
.onm add separator
.onm add command -label "Help\u2026" -underline 0 -command "help simulator"
.onm add command -label "About\u2026" -underline 0 -command "about"
.onm add separator
.onm add command -label "Exit" -underline 1 -command "exit_handler"
if {$trigger == 3} {
tk_popup .onm [winfo pointerx .] [winfo pointery .]
} else {
tk_popup .onm [winfo rootx .btn_41.btn] \
[expr [winfo rooty .btn_41.btn]+[winfo height .btn_41.btn]]
}
}
# ------------------------------------------------------------------------------
proc show_storage { function trigger } {
global LAYOUT HP15 storage
if {[winfo exists .storage]} {destroy .storage}
menu .storage -tearoff 0 -title "Storage" -font $LAYOUT(FnMenu)
set regmax [expr $HP15(dataregs) < 19 ? $HP15(dataregs) : 19]
for {set ii 0} {$ii <= $regmax} {incr ii} {
.storage add command \
-label "R[format "%2d" $ii]: [format_number $storage($ii)]"
if {$ii < 10} {
.storage entryconfigure $ii -underline 2 \
-command "dispatch_key $function\_$ii"
} else {
.storage entryconfigure 10 -columnbreak $HP15(breakstomenu)
.storage entryconfigure $ii \
-command "dispatch_key $function\_48_[expr $ii-10]"
}
}
.storage add command
.storage entryconfigure $ii -label "RI : [format_number $storage(I)]" \
-underline 1 -command "dispatch_key $function\_25"
if {$trigger == 3} {
tk_popup .storage [winfo pointerx .] [winfo pointery .]
} else {
tk_popup .storage [winfo rootx .btn_$function.gbtn] \
[winfo rooty .btn_$function.gbtn]
}
}
# ------------------------------------------------------------------------------
proc show_content { trigger } {
global status
if {$status(error)} {
show_error $trigger
} elseif {$status(PRGM)} {
show_prgm $trigger
} else {
show_stack $trigger
}
}
# ------------------------------------------------------------------------------
proc show_stack { trigger } {
global FLAG LAYOUT stack istack
if {[winfo exists .stack]} {destroy .stack}
menu .stack -tearoff 0 -title "Stack" -font $LAYOUT(FnMenu)
set sts 3
foreach ii {t z y x} {
if {$FLAG(8)} {
.stack add command -command "func_roll $sts" -hidemargin 1 -label \
[format {%5s: %-15s %5s: %-15s} $ii [format_number $stack($ii)] \
i$ii [format_number $istack($ii)]]
} else {
.stack add command -command "func_roll $sts" -hidemargin 1 -label \
[format {%5s: %-15s} $ii [format_number $stack($ii)]]
}
incr sts -1
}
.stack add separator
if {$FLAG(8)} {
.stack add command -command "dispatch_key 43_36" -hidemargin 1 -label \
[format { LSTx: %-15s iLSTX: %-15s} [format_number $stack(LSTx)] \
[format_number $istack(LSTx)]]
} else {
.stack add command -label " LSTx: [format_number $stack(LSTx)]" \
-command "dispatch_key 43_36" -hidemargin 1
}
if {$trigger == 3} {
tk_popup .stack [winfo pointerx .] [winfo pointery .]
} else {
tk_popup .stack [winfo rootx .status] \
[expr [winfo rooty .status] + [winfo height .status]]
}
}
# ------------------------------------------------------------------------------
proc show_error { trigger } {
global LAYOUT stack
if {![winfo exists .error]} {
menu .error -tearoff 0 -title "Error" -font $LAYOUT(FnMenu)
.error add command -label " 0 : y \u00F7 0, LN 0, \u2026" -state disabled
.error add command -label " 1 : LN A, SIN A, \u2026" -state disabled
.error add command -label " 2 : \u2211 Error" -state disabled
.error add command -label " 3 : R?, Aij?" -state disabled
.error add command -label " 4 : LBL?, GTO > MEM, PRGM > MEM" -state disabled
.error add command -label " 5 : > 7 RTN" -state disabled
.error add command -label " 6 : SF > 9, CF > 9, F? > 9" -state disabled
.error add command -label " 7 : SOLVE(SOLVE), \u222Bxy(\u222Bxy)" \
-state disabled
.error add command -label " 8 : SOLVE ?" -state disabled
.error add command -label " 9 : ON / \u00D7" -state disabled
.error add command -label "10 : DIM > MEM" -state disabled
.error add command -label "11 : DIM A \u2260 DIM B" -state disabled
.error add separator
.error add command -label "98 : File I/O error" -state disabled
.error add command -label "99 : Tcl/Tk error" -state disabled
.error configure -disabledforeground [.error cget -foreground]
}
if {$trigger == 3} {
tk_popup .error [winfo pointerx .] [winfo pointery .]
} else {
tk_popup .error [winfo rootx .status] \
[expr [winfo rooty .status] + [winfo height .status]]
}
}
# ------------------------------------------------------------------------------
proc lift {} {
foreach ii {stack istack} {
upvar #0 $ii st
set st(t) $st(z)
set st(z) $st(y)
set st(y) $st(x)
}
}
# ------------------------------------------------------------------------------
proc drop {} {
foreach ii {stack istack} {
upvar #0 $ii st
set st(x) $st(y)
set st(y) $st(z)
set st(z) $st(t)
}
}
# ------------------------------------------------------------------------------
proc move { from to } {
global stack istack
set stack($to) $stack($from)
set istack($to) $istack($from)
}
# ------------------------------------------------------------------------------
proc populate { val } {
foreach ii {stack istack} {
upvar #0 $ii st
foreach jj {x y z t} {
set st($jj) $val
}
}
}
# ------------------------------------------------------------------------------
proc set_status { st } {
global status FLAG PI
switch $st {
user {
set status(user) [expr !$status(user)]
set status(f) 0
toggle_user $status(user)
show_x
}
f {
if {!$status(f)} {
set status(f) [expr !$status(f)]
set status(g) 0
}
}
g {
if {!$status(g)} {
set status(g) [expr !$status(g)]
set status(f) 0
}
}
fg_off {
set status(f) 0
set status(g) 0
}
BEGIN {
set status(BEGIN) [expr !$status(BEGIN)]
}
DEG {
set status(RAD) ""
set status(RADfactor) $PI/180.0
show_x
}
RAD {
set status(RAD) $st
set status(RADfactor) 1.0
show_x
}
GRAD {
set status(RAD) $st
set status(RADfactor) [expr 0.9*$PI/180.0]
show_x
}
PRGM {
set status(PRGM) [expr !$status(PRGM)]
}
}
if [winfo exists .status] {
.status itemconfigure suser -text [expr $status(user) ? \"USER\" : \"\"]
.status itemconfigure sf -text [expr $status(f) ? \"f\" : \" \"]
.status itemconfigure sg -text [expr $status(g) ? \"g\" : \" \"]
.status itemconfigure sbegin -text [expr $status(BEGIN) ? \"BEGIN\" : \" \"]
.status itemconfigure srad -text $status(RAD)
.status itemconfigure scomplex -text [expr $FLAG(8) ? \"C\" : \" \"]
.status itemconfigure sprgm -text [expr $status(PRGM) ? \"PRGM\" : \"\"]
}
}
# ------------------------------------------------------------------------------
proc count_digits { var } {
set rc 0
for {set ii 0} {$ii < [string length $var]} {incr ii} {
if {[string is digit [string index $var $ii]]} {
incr rc
} elseif {[string index $var $ii] == "e"} {
break
}
}
return $rc
}
# ------------------------------------------------------------------------------
proc func_digit { digit } {
global status stack istack
if {$status(num)} {
if {!$status(liftlock)} {lift}
if {$status(liftlock) < 2} {set istack(x) 0.0}
set status(num) 0
if {$digit == "e+0"} {
set digit "1$digit"
} elseif {$digit == "."} {
set digit "0."
}
set stack(x) $digit
} else {
set stack_x $stack(x)
if {$digit == "e+0" &&
([string first "e" $stack_x] > 0 || [count_digits $stack_x] > 7)} {
set digit ""
}
set comma [string first "." $stack_x]
if {[count_digits $stack_x] < 10 && !($digit == "." && $comma != -1)} {
if {[string first "e" $stack_x] > 0} {
regsub {([-+ ]?[0-9]+e[+-])[0-9]([0-9])$} $stack_x {\1\2} stack_x
}
set stack_x "$stack_x$digit"
# Avoid integer overflow for 10-digit integers. Obsolete with Tcl/Tk >= 8.4?
if {[count_digits $stack_x] == 10 && $comma == -1 && \
[string first "e" $stack_x] < 0} {
set stack_x "$stack_x."
}
set stack(x) $stack_x
}
}
set status(liftlock) 0
}
# ------------------------------------------------------------------------------
proc func_sqrt {} {
global FLAG stack
if {$FLAG(8)} {
move x u
csqrt
move u x
} else {
set stack(x) [expr sqrt($stack(x))]
}
}
# ------------------------------------------------------------------------------
proc func_xpow2 {} {
global FLAG stack istack
if {$FLAG(8)} {
set stack(x) [expr 1.0*$stack(x)*$stack(x) - $istack(x)*$istack(x)]
set istack(x) [expr 2.0*$stack(s)*$istack(x)]
} else {
set stack(x) [expr pow($stack(x), 2)]
}
}
# ------------------------------------------------------------------------------
proc func_exp {} {
global FLAG stack istack
if {$FLAG(8)} {
set stack(x) [expr exp($stack(x))*cos($istack(x))]
set istack(x) [expr exp($stack(s))*sin($istack(x))]
} else {
set stack(x) [expr exp($stack(x))]
}
}
# The following are helper functions for the complex mode. They solely operate
# on stack register u.
# ------------------------------------------------------------------------------
proc cabs {} {
global stack istack
return [expr sqrt(1.0*$stack(u)*$stack(u) + 1.0*$istack(u)*$istack(u))]
}
# ------------------------------------------------------------------------------
proc cphi {} {
global PI stack istack
set ret [expr atan($istack(u)/$stack(u))]
if {$stack(u) < 0.0} {
set mod [expr $istack(u) >= 0.0 ? $PI : -$PI]
} else {
set mod 0.0
}
set ret [expr $ret+$mod]
return $ret
}
# ------------------------------------------------------------------------------
proc csqrt {} {
global stack istack
set tmp $stack(u)
set xb [cabs]
set stack(u) [expr sqrt(($stack(u) + $xb)/2.0)]
set istack(u) [expr ($istack(u) < 0 ? -1.0 : 1.0)*sqrt((-$tmp + $xb)/2.0)]
}
# ------------------------------------------------------------------------------
proc cln {} {
global PI stack istack
set tmp $stack(u)
set stack(u) [expr 0.5*log(1.0*$stack(u)*$stack(u)+1.0*$istack(u)*$istack(u))]
if {$tmp != 0.0} {
set mod 0.0
if {$tmp < 0.0} {set mod [expr $istack(u) >= 0.0 ? $PI : -$PI]}
set istack(u) [expr atan($istack(u)/$tmp) + $mod]
} else {
set istack(u) [expr $istack(x) >= 0.0 ? $PI/2.0 : -$PI/2.0]
}
}
# ------------------------------------------------------------------------------
proc func_ln {} {
global FLAG stack istack
if {$FLAG(8)} {
if {$stack(x) == 0.0 && $istack(x) == 0.0} {
error "" "" {ARITH INVALID}
} else {
move x u
cln
move u x
}
} else {
if {$stack(x) == 0.0} {
error "" "" {ARITH INVALID}
} else {
set stack(x) [expr log($stack(x))]
}
}
}
# ------------------------------------------------------------------------------
proc func_10powx {} {
global PI status FLAG stack istack
if {$FLAG(8)} {
set stack(x) [expr pow(10.0,$stack(x))*cos($istack(x)*log(10.0))]
set istack(x) [expr pow(10.0,$stack(s))*sin($istack(s)*log(10.0))]
} else {
set stack(x) [expr pow(10.0, $stack(x))]
}
}
# ------------------------------------------------------------------------------
proc func_log10 {} {
global FLAG stack istack
if {$FLAG(8)} {
if {$stack(x) == 0.0 && $istack(x) == 0.0} {
error "" "" {ARITH INVALID}
} else {
move x u
cln
set stack(x) [expr $stack(u)/log(10.0)]
set istack(x) [expr $istack(u)/log(10.0)]
}
} else {
if {$stack(x) == 0.0} {
error "" "" {ARITH INVALID}
} else {
set stack(x) [expr log10($stack(x))]
}
}
}
# ------------------------------------------------------------------------------
proc func_ypowx {} {
global FLAG stack istack PI
if {$FLAG(8)} {
move y u
set stack(y) [expr pow([cabs],$stack(x))*exp(-$istack(x)*[cphi])]
set istack(y) [expr $stack(x)*[cphi] + $istack(x)*log([cabs])]
set lx $stack(y)
set stack(y) [expr cos($istack(y))*$stack(y)]
set istack(y) [expr sin($istack(y))*$lx]
} else {
set stack(y) [expr pow($stack(y), $stack(x))]
}
drop
}
# ------------------------------------------------------------------------------
proc func_percent {} {
global stack
set stack(x) [expr ($stack(y)/100.0) * $stack(x)]
}
# ------------------------------------------------------------------------------
proc func_inv {} {
global FLAG stack istack
if {$FLAG(8)} {
move x u
set xb [expr pow([cabs],2)]
set stack(x) [expr $stack(x)/$xb]
set istack(x) [expr -$istack(s)/$xb]
} else {
set stack(x) [expr 1.0/$stack(x)]
}
}
# ------------------------------------------------------------------------------
proc func_dpercent {} {
global stack
set stack(x) [expr ($stack(x)-$stack(y))/($stack(y)/100.0)]
}
# ------------------------------------------------------------------------------
proc func_dsp_mode { mode param } {
global status storage
if {$param == "I"} {
if {$storage(I) < 0} {
set param 0
} else {
set param [expr int($storage(I)) > 9 ? 9 : int($storage(I))]
}
}
set status(dispmode) $mode
set status(dispprec) $param
show_x
}
# ------------------------------------------------------------------------------
proc lookup_label { lbl } {
global prgstat PRGM
if {$lbl < 0} {
set target "42_21_1[expr abs($lbl)]"
} elseif {$lbl > 9} {
set target "42_21_48_[expr int($lbl - 10)]"
} else {
set target "42_21_$lbl"
}
set tl -1
set wrap 0
set ll [expr $prgstat(curline)+1]
while {!$wrap} {
if {$ll > [llength $PRGM]} {set ll 0}
if {[lindex $PRGM $ll] == "$target"} {
set tl $ll
break
} elseif {$ll == $prgstat(curline)} {
set wrap 1
}
incr ll
}
return $tl
}
# ------------------------------------------------------------------------------
proc func_label { lbl } {
show_x
}
# ------------------------------------------------------------------------------
proc func_sst { {ev 0} } {
global HP15 status prgstat PRGM
if {$status(PRGM)} {
if {$ev == 0 || $ev == 2 || $ev == 4} {
incr prgstat(curline)
if {$prgstat(curline) >= [llength $PRGM]} {
set prgstat(curline) 0
}
show_curline
}
} else {
if {$ev == 0 || $ev == 2 || $ev == 4} {
if {$prgstat(curline) == 0 && [llength $PRGM] > 1} {incr prgstat(curline)}
show_curline
if {$ev == 0} {after $HP15(pause) {show_x}}
} else {
set prgstat(running) 1
prgm_step
set prgstat(running) 0
show_x
}
}
}
# ------------------------------------------------------------------------------
proc func_bst { {ev 0} } {
global HP15 status prgstat PRGM
if {$status(PRGM) || $ev == 0 || $ev == 2 || $ev == 4} {
if {$prgstat(curline) > 0} {
incr prgstat(curline) -1
} else {
set prgstat(curline) [expr [llength $PRGM] - 1]
}
show_curline
}
if {!$status(PRGM)} {
if {$ev == 0 || $ev == 2 || $ev == 4} {
set status(num) 1
if {$ev == 0} {after $HP15(pause) {show_x}}
} else {
show_x
}
}
}
# ------------------------------------------------------------------------------
proc func_gto_chs { trigger } {
global status
if {!$status(error)} {show_prgm $trigger}
}
# ------------------------------------------------------------------------------
proc func_gto { lbl } {
global HP15 storage prgstat PRGM
if {$lbl == "I"} {
set lbl [expr int($storage(I))]
if {$lbl < 0 && abs($lbl) <= [llength $PRGM]} {
set ll [expr abs($lbl)]
} elseif {$lbl >= 0 && $lbl <= $HP15(dataregs)} {
set ll [lookup_label $lbl]
} elseif {$lbl >= 20 && $lbl <= 24} {
set ll [lookup_label [expr 19-$lbl]]
} else {
set ll -1
}
} else {
set ll [lookup_label $lbl]
}
if {$ll == -1} {
error "" "" {ADDRESS}
} else {
set prgstat(curline) $ll
}
}
# ------------------------------------------------------------------------------
proc func_gsb { lbl } {
global HP15 prgstat
if {$lbl == "I"} {
set lbl [expr int($storage(I))]
if {$lbl < 0 && abs($lbl) <= [llength $PRGM]} {
set ll [expr abs($lbl)]
} elseif {$lbl >= 0 && $lbl <= $HP15(dataregs)} {
set ll [lookup_label $lbl]
} elseif {$lbl >= 20 && $lbl <= 24} {
set ll [lookup_label [expr 19-$lbl]]
} else {
set ll -1
}
} else {
set ll [lookup_label $lbl]
}
if {$ll == -1} {
error "" "" {ADDRESS}
} elseif {$prgstat(running)} {
if {[llength $prgstat(rtnadr)] <= $HP15(gsbmax)} {
lappend prgstat(rtnadr) [expr $prgstat(curline)+1]
set prgstat(curline) $ll
} else {
error "" "" {RTN}
}
} else {
prgm_run $ll
}
}
# ------------------------------------------------------------------------------
proc func_hyp { func } {
global FLAG stack istack
if {$FLAG(8)} {
switch $func {
sin {
set stack(x) [expr sinh($stack(x))*cos($istack(x))]
set istack(x) [expr cosh($stack(s))*sin($istack(x))]
}
cos {
set stack(x) [expr cosh($stack(x))*cos($istack(x))]
set istack(x) [expr sinh($stack(s))*sin($istack(x))]
}
tan {
set divi [expr pow(cosh($stack(x))*cos($istack(x)),2)+ \
pow(sinh($stack(s))*sin($istack(x)),2)]
set stack(x) [expr sinh($stack(x))*cosh($stack(x))/$divi]
set istack(x) [expr sin($istack(x))*cos($istack(x))/$divi]
}
}
} else {
set stack(x) [expr $func\h($stack(x))]
}
}
# ------------------------------------------------------------------------------
proc func_ahyp { func } {
global FLAG stack istack
if {$FLAG(8)} {
set stack(u) [expr 1.0*$stack(x)*$stack(x) - $istack(x)*$istack(x)]
set istack(u) [expr 2.0*$stack(x)*$istack(x)]
switch $func {
sin {
set stack(u) [expr $stack(u)+1.0]
csqrt
set stack(u) [expr $stack(x)+$stack(u)]
set istack(u) [expr $istack(x)+$istack(u)]
cln
move u x
}
cos {
set stack(u) [expr $stack(u)-1.0]
csqrt
set stack(u) [expr $stack(x)+$stack(u)]
set istack(u) [expr $istack(x)+$istack(u)]
cln
set sg [expr $stack(s) < 0.0 ? -1.0 : 1.0]
set stack(x) [expr $sg*$stack(u)]
set istack(x) [expr $sg*$istack(u)]
}
tan {
set divi [expr 1.0-2.0*$stack(x)+pow($stack(x),2)-pow($istack(x),2)]
set stack(u) [expr (1.0-pow($stack(x),2)+pow($istack(x),2))/$divi]
set istack(u) [expr -2.0*$stack(x)*$istack(x)/$divi]
cln
set stack(x) [expr 0.5*$stack(u)]
set istack(x) [expr 0.5*$istack(u)]
}
}
} else {
switch $func {
sin {
set stack(x) [expr log($stack(x) + sqrt($stack(x)*$stack(x) + 1.0))]
}
cos {
set stack(x) [expr log($stack(x) - sqrt($stack(x)*$stack(x) - 1.0))]
}
tan {
set stack(x) [expr log(sqrt((1.0 + $stack(x)) / (1.0 - $stack(x))))]
}
}
}
}
# ------------------------------------------------------------------------------
proc func_trign { func } {
global status FLAG stack istack
if {$FLAG(8)} {
switch $func {
sin {
set stack(x) [expr sin($stack(x))*cosh($istack(x))]
set istack(x) [expr cos($stack(s))*sinh($istack(x))]
}
cos {
set stack(x) [expr cos($stack(x))*cosh($istack(x))]
set istack(x) [expr -sin($stack(s))*sinh($istack(x))]
}
tan {
set divi [expr cos(2.0*$stack(x))+cosh(2.0*$istack(x))]
set stack(x) [expr sin(2.0*$stack(x))/$divi]
set istack(x) [expr sinh(2.0*$istack(x))/$divi]
}
}
} else {
set stack(x) [expr $func\($stack(x)*$status(RADfactor))]
}
}
# ------------------------------------------------------------------------------
proc func_atrign { func } {
global status FLAG stack istack
if {$FLAG(8)} {
set stack(u) [expr $stack(x)*$stack(x) - $istack(x)*$istack(x)]
set istack(u) [expr 2.0*$stack(x)*$istack(x)]
switch $func {
sin {
set stack(u) [expr 1.0-$stack(u)]
set istack(u) [expr -$istack(u)]
csqrt
set stack(u) [expr -$istack(x)+$stack(u)]
set istack(u) [expr $stack(x)+$istack(u)]
cln
set stack(x) $istack(u)
set istack(x) [expr -$stack(u)]
}
cos {
set stack(u) [expr $stack(u)-1.0]
csqrt
set stack(u) [expr $stack(x)+$stack(u)]
set istack(u) [expr $istack(x)+$istack(u)]
cln
set sg [expr $stack(s)*$istack(s) < 0.0 ? -1.0 : 1.0]
set stack(x) [expr $sg*$istack(u)]
set istack(x) [expr -$sg*$stack(u)]
}
tan {
set divi [expr 1.0+2.0*$istack(x)+pow($istack(x),2)+pow($stack(x),2)]
set stack(u) [expr (1.0-pow($istack(x),2)-pow($stack(x),2))/$divi]
set istack(u) [expr 2.0*$stack(x)/$divi]
cln
set stack(x) [expr 0.5*$istack(u)]
set istack(x) [expr -0.5*$stack(u)]
}
}
} else {
set stack(x) [expr a$func\($stack(x))/$status(RADfactor)]
}
}
# ------------------------------------------------------------------------------
proc func_dim_mem {} {
global HP15 stack storage
set rr [expr abs(int($stack(x)))]
if {$rr < 1} {set rr 1}
if {$rr > $HP15(dataregs) + $HP15(prgmregsfree)} {
error "" "" {DIM}
} else {
for {set ii [expr $rr+1]} {$ii <= $HP15(dataregs)} {incr ii} {
array unset storage $ii
}
for {set ii [expr $HP15(dataregs)+1]} {$ii <= $rr} {incr ii} {
set storage($ii) 0.0
}
set HP15(dataregs) $rr
mem_recalc
}
show_x
}
# ------------------------------------------------------------------------------
proc func_i { {ev 0} } {
global HP15 status FLAG istack curdisp
if {!$status(PRGM)} {
if {$FLAG(8)} {
if {$ev == 0 || $ev == 2 || $ev == 4} {
set curdisp [format_number $istack(x)]
if {$ev == 0} {after $HP15(pause) {show_x}}
} else {
after $HP15(pause) {show_x}
}
} else {
if {$ev == 0 || $ev == 3 || $ev ==5} {error_handler {INDEX}}
}
}
}
# ------------------------------------------------------------------------------
proc func_I {} {
global FLAG stack istack
if {!$FLAG(8)} {func_sf 8}
set istack(y) $stack(x)
drop
}
# ------------------------------------------------------------------------------
proc func_pi {} {
global stack istack PI
lift
set stack(x) $PI
set istack(x) 0.0
}
# ------------------------------------------------------------------------------
proc func_sf { flag } {
global HP15 FLAG storage
if {$flag == "I"} {set flag [expr int($storage(I))]}
if {$flag == 8 && $HP15(prgmregsfree) < 5} {
error "" "" {DIM}
}
if {$flag >= 0 && $flag <= 9} {
set FLAG($flag) 1
set_status NIL
show_x
} else {
error "" "" {FLAG}
}
}
# ------------------------------------------------------------------------------
proc func_cf { flag } {
global FLAG istack storage
if {$flag == "I"} {set flag [expr int($storage(I))]}
if {$flag >= 0 && $flag <= 9} {
if {$flag == 8} {foreach ii {LSTx x y z t u s} {set istack($ii) 0.0 }}
set FLAG($flag) 0
set_status NIL
show_x
} else {
error "" "" {FLAG}
}
}
# ------------------------------------------------------------------------------
proc show_flags { trigger } {
global LAYOUT status FLAG
if {[winfo exists .flags]} {destroy .flags}
menu .flags -tearoff 0 -title "Flags" -font $LAYOUT(FnMenu)
if {$status(PRGM)} {
set st normal
} else {
set st disabled
}
for {set ii 0} {$ii <= 9} {incr ii} {
.flags add command -label "$ii: $FLAG($ii)" -state $st \
-command "dispatch_key 43_6_$ii"
}
if {$trigger == 3} {
tk_popup .flags [winfo pointerx .] [winfo pointery .]
} else {
tk_popup .flags [winfo rootx .btn_29.gbtn] \
[expr [winfo rooty .btn_29.gbtn]+[winfo height .btn_29.gbtn]]
}
}
# ------------------------------------------------------------------------------
proc func_Finq { flag } {
global prgstat storage FLAG
if {$prgstat(running)} {
if {$flag == "I"} {set flag [expr int($storage(I))]}
if {$flag >= 0 && $flag <= 9} {
if {$FLAG($flag) == 0} {incr prgstat(curline) 2}
} else {
error "" "" {FLAG}
}
}
}
# ------------------------------------------------------------------------------
proc func_clearsumregs {} {
global HP15 stack istack storage
if {$HP15(dataregs) < 7} {
error "" "" {INDEX}
} else {
for {set ii 2} {$ii < 7} {incr ii} {
set storage($ii) 0.0
}
}
foreach ii {x y z t} {
set stack($ii) 0.0
set istack($ii) 0.0
}
}
# ------------------------------------------------------------------------------
proc disp_scroll { inc } {
global status
if {$status(PRGM)} {
if {$inc >= 0.0} {
dispatch_key 21
} else {
dispatch_key 43_21
}
} else {
func_roll [expr $inc >= 0 ? 3 : 1]
}
}
# ------------------------------------------------------------------------------
proc func_roll { cnt } {
global status
set status(num) 1
for {set ii 0} {$ii < $cnt} {incr ii} {
foreach jj {stack istack} {
upvar #0 $jj st
set tmp $st(y)
set st(y) $st(z)
set st(z) $st(t)
set st(t) $st(x)
set st(x) $tmp
}
}
show_x
}
# ------------------------------------------------------------------------------
proc func_chs {} {
global status stack
if {$status(num)} {
set stack(x) [expr -$stack(x)]
} else {
if {[string first "e" $stack(x)] > 0} {
set stack(x) [string map {e+ e- e- e+} $stack(x)]
} else {
if {[string index $stack(x) 0] == "-"} {
set stack(x) [string range "$stack(x)" 1 end]
} else {
set stack(x) "-$stack(x)"
}
}
}
}
# ------------------------------------------------------------------------------
proc func_abs {} {
global FLAG stack istack
if {$FLAG(8)} {
move x u
set stack(x) [cabs]
set istack(x) 0.0
} else {
set stack(x) [expr abs($stack(x))]
}
}
# ------------------------------------------------------------------------------
proc func_xexchg { param } {
global stack storage
set param [GETREG $param]
set tmp $storage($param)
set storage($param) $stack(x)
set stack(x) $tmp
}
# ------------------------------------------------------------------------------
proc func_dse { param } {
global storage prgstat PRGM
set param [GETREG $param]
set nn [expr int($storage($param))]
set yy [expr abs(($storage($param) - $nn)*1E3)]
set xx [expr int($yy)]
set yy [expr int(100.0 * ($yy - $xx))]
set nn [expr $nn-[expr $yy == 0.0 ? 1 : $yy]]
if {$nn <= $xx} {
if {$prgstat(curline) < [llength $PRGM]} {incr prgstat(curline) 2}
}
set storage($param) "$nn.[format "%03d" $xx][format "%02d" $yy]"
}
# ------------------------------------------------------------------------------
proc func_isg { param } {
global storage prgstat PRGM
set param [GETREG $param]
set nn [expr int($storage($param))]
set yy [expr abs(($storage($param) - $nn)*1E3)]
set xx [expr int($yy)]
set yy [expr int(100.0 * ($yy - $xx))]
if {$yy == 0.0} {set yy 1}
set nn [expr $nn+[expr $yy == 0.0 ? 1 : $yy]]
if {$nn > $xx} {
if {$prgstat(curline) < [llength $PRGM]} {incr prgstat(curline) 2}
}
set storage($param) "$nn.[format "%03d" $xx][format "%02d" $yy]"
}
# ------------------------------------------------------------------------------
proc regula_falsi { lbl x0 x1 } {
global stack prgstat
set ebs 1E-14
set iter 0
while {1} {
populate $x1
func_gsb $lbl
set f_x1 $stack(x)
populate $x0
func_gsb $lbl
set f_x0 $stack(x)
set x2 [expr $x0 - $f_x0 * (($x0 - $x1)/($f_x0 - $f_x1))]
populate $x2
func_gsb $lbl
set f_x2 $stack(x)
if {$f_x0 == $f_x2 || [incr iter] > $prgstat(maxiter)} {
error "" "" {SOLVE}
}
set x0 $x1
set x1 $x2
if {[expr abs($x0 - $x1)] <= $ebs} {break}
}
set stack(z) $f_x2
set stack(y) $x1
set stack(x) $x2
}
# ------------------------------------------------------------------------------
proc func_solve { lbl } {
global HP15 status stack
if {$status(solve)} {error "" "" {RECURSION}}
set status(solve) 1
set ll [lookup_label $lbl]
if {$HP15(prgmregsfree) < 5} {
error "" "" {DIM}
} elseif {$ll == -1} {
error "" "" {ADDRESS}
} else {
if {$stack(x) < $stack(y)} {func_xy}
regula_falsi $lbl $stack(y) $stack(x)
}
set status(solve) 0
}
# ------------------------------------------------------------------------------
proc simpson { lbl lb ub steps } {
global stack
set st [expr ($ub-$lb)/($steps*1.0)]
set res 0.0
for {set ii 0} {$ii < $steps} {incr ii 2} {
populate [expr $lb+$ii*$st]
func_gsb $lbl
set res [expr $res+$stack(x)]
populate [expr $lb+($ii+1)*$st]
func_gsb $lbl
set res [expr $res+4.0*$stack(x)]
populate [expr $lb+($ii+2)*$st]
func_gsb $lbl
set res [expr $res+$stack(x)]
}
return [expr $res*$st/3.0]
}
# ------------------------------------------------------------------------------
proc func_integrate { lbl } {
global HP15 status stack
if {$status(integrate)} {error "" "" {RECURSION}}
set status(integrate) 1
set ll [lookup_label $lbl]
if {$HP15(prgmregsfree) < 23} {
error "" "" {DIM}
} elseif {$ll == -1} {
error "" "" {ADDRESS}
} else {
set lb $stack(y)
set ub $stack(x)
set steps 32
set res1 0.0
set res2 0.0
set delta 0.0
while {1} {
if {[catch {set res [simpson $lbl $lb $ub $steps]} einf]} {
error "" "" {INTERRUPT}
return
}
if {$status(dispmode) == "FIX"} {
set log 0
} else {
set log [expr $res != 0 ? int(floor(log10(abs($res)))) : 0]
}
set prec [expr 0.5 * pow(10, -$status(dispprec)+$log)]
set delta [expr $delta + (($ub - $lb) / $steps * $prec)]
if {[expr abs($res1-$res)] < $delta || [expr abs($res2-$res)] < $delta} {
break
} else {
set res1 $res2
set res2 $res
}
set steps [expr 2*$steps]
}
set stack(t) $lb
set stack(z) $ub
set status(integrate) 0
set status(num) 1
set stack(y) $delta
set stack(x) $res
}
}
# ------------------------------------------------------------------------------
proc func_clearprgm {} {
global HP15 status prgstat PRGM
set prgstat(curline) 0
set prgstat(interrupt) 0
if {$status(PRGM)} {
set HP15(prgmname) ""
set prgstat(running) 0
set prgstat(rtnadr) {0}
set PRGM {{}}
show_curline
mem_recalc
} else {
show_x
}
}
# ------------------------------------------------------------------------------
proc func_clearreg {} {
global HP15 storage
for {set ii 0} {$ii <= $HP15(dataregs)} {incr ii} {
set storage($ii) 0.0
}
set storage(I) 0.0
}
# ------------------------------------------------------------------------------
proc func_rnd {} {
global status stack
set stack(x) [format "%.$status(dispprec)f" $stack(x)]
}
# ------------------------------------------------------------------------------
proc func_xy {} {
global status
foreach ii {stack istack} {
upvar #0 $ii st
set tmp $st(y)
set st(y) $st(x)
set st(x) $tmp
}
}
# ------------------------------------------------------------------------------
proc func_prefix { {ev 0} } {
global HP15 status stack curdisp
if {!$status(PRGM)} {
if {$ev == 0 || $ev == 2 || $ev == 4} {
set curdisp " [string map {. ""} [format "%.10e" [expr abs($stack(x))]]]"
if {$ev == 0} {after $HP15(pause) {show_x}}
} else {
after $HP15(pause) {show_x}
}
}
}
# ------------------------------------------------------------------------------
proc func_bs {} {
global status stack FLAG prgstat PRGM
if {$status(PRGM)} {
if {$prgstat(curline) > 0} {
set PRGM [lreplace $PRGM $prgstat(curline) $prgstat(curline)]
incr prgstat(curline) -1
mem_recalc
show_curline
}
} else {
if {$FLAG(9)} {
set FLAG(9) 0
} elseif {$status(num)} {
set stack(x) 0.0
set status(liftlock) 2
} else {
regsub {e[+-]0?$} $stack(x) "e" temp
regsub {^-[0-9]$} $temp "" temp
if {[string length $temp] > 1} {
# Remove period added to 10-digit integers in 'func_digit'
if {[count_digits $temp] == 10 && [string index $temp end] == "."} {
set temp "[string range $temp 0 end-1]"
}
set stack(x) "[string range $temp 0 end-1]"
} else {
set status(liftlock) 2
set status(num) 1
set stack(x) 0.0
}
}
}
}
# ------------------------------------------------------------------------------
proc func_clx {} {
global status stack
set stack(x) 0.0
set status(liftlock) 3
}
# ------------------------------------------------------------------------------
proc clearall {} {
populate 0.0
func_clearreg
func_clx
func_digit 0
dispatch_key 20
move x u
move x m
}
# ------------------------------------------------------------------------------
proc func_frac {} {
global stack
set stack(x) [expr ($stack(x) - int($stack(x)))*1.0]
}
# ------------------------------------------------------------------------------
proc GETREG { param } {
global HP15 storage
if {$param == "(i)"} {set param [expr int($storage(I))]}
if {($param < 0 || $param > $HP15(dataregs)) && $param != "I"} {
error "" "" {INDEX}
return
}
return $param
}
# ------------------------------------------------------------------------------
proc func_sto { param } {
global stack storage
set storage([GETREG $param ]) [expr $stack(x)*1.0]
show_x
}
# ------------------------------------------------------------------------------
proc func_sto_oper { fn param } {
global stack storage
set param [GETREG $param ]
set storage($param) [expr $storage($param) $fn $stack(x)*1.0]
show_x
}
# ------------------------------------------------------------------------------
proc func_int {} {
global stack
set stack(x) [expr 1.0*int($stack(x))]
}
# ------------------------------------------------------------------------------
proc toggle_user { mode } {
if {$mode} {
for {set ii 1} {$ii < 5} {incr ii} {
bind .btn_1$ii.fbtn "<Button-1>" "dispatch_key 1$ii"
bind .btn_1$ii.btn "<Button-1>" "key_event 1$ii 42_1$ii"
}
} else {
for {set ii 1} {$ii < 5} {incr ii} {
bind .btn_1$ii.fbtn "<Button-1>" "dispatch_key 42_1$ii"
bind .btn_1$ii.btn "<Button-1>" "key_event 1$ii 1$ii"
}
}
}
# ------------------------------------------------------------------------------
proc func_rcl { param } {
global stack istack storage
lift
set stack(x) $storage([GETREG $param])
set istack(x) 0.0
}
# ------------------------------------------------------------------------------
proc func_rcl_oper { fn param } {
global stack istack storage
set stack(x) [expr $stack(x)*1.0 $fn $storage([GETREG $param])]
set istack(x) 0.0
}
# ------------------------------------------------------------------------------
proc func_rclsum {} {
global HP15 status stack istack storage
if {$HP15(dataregs) < 7} {
error "" "" {INDEX}
} else {
lift
if {!$status(liftlock)} {lift}
set stack(y) $storage(5)
set istack(y) 0.0
set stack(x) $storage(3)
set istack(x) 0.0
}
}
# ------------------------------------------------------------------------------
proc mem_recalc {} {
global HP15 PRGM
set HP15(prgmregsused) [expr int(ceil(([llength $PRGM]-1)/7.0))]
set HP15(freebytes) [expr int(($HP15(prgmregsused)*7)-[llength $PRGM]+1)]
set HP15(prgmregsfree) \
[expr $HP15(totregs)-$HP15(dataregs)-$HP15(prgmregsused)]
}
# ------------------------------------------------------------------------------
proc func_mem { {ev 0} } {
global HP15 curdisp
if {$ev == 0 || $ev == 2 || $ev == 4} {
mem_recalc
set curdisp [format " %2d %2d %2d-%d" \
$HP15(dataregs) $HP15(prgmregsfree) $HP15(prgmregsused) $HP15(freebytes)]
}
if {$ev == 0 || $ev == 3 || $ev == 5} {
after $HP15(pause) {
if {$status(PRGM)} {
show_curline
} else {
show_x
}
}
}
}
# ------------------------------------------------------------------------------
proc func_random {} {
global stack istack
lift
set stack(x) [expr rand()]
set istack(x) 0.0
}
# ------------------------------------------------------------------------------
proc func_storandom {} {
global status stack
set ax [expr abs($stack(x))]
set log [expr $ax > 1.0 ? int(log10($ax))+1 : 0]
set status(seed) [expr $ax / pow(10.0, $log)]
expr srand(int($ax))
show_x
}
# ------------------------------------------------------------------------------
proc func_rclrandom {} {
global status stack
set stack(x) $status(seed)
set istack(x) 0.0
}
# ------------------------------------------------------------------------------
proc func_polar {} {
global PI status FLAG stack istack
if {$FLAG(8)} {
move x u
set stack(x) [cabs]
set istack(x) [expr [cphi]/$status(RADfactor)]
} else {
set stack(x) [expr sqrt(1.0*$stack(x)*$stack(x) + 1.0*$stack(y)*$stack(y))]
set stack(y) [expr (180.0/$PI)*asin($stack(y)/$stack(x))]
}
}
# ------------------------------------------------------------------------------
proc faculty { var } {
set res 1.0
set var [expr int($var)]
for {set ii $var} {$ii > 1} {incr ii -1} {
set res [expr $res * $ii]
}
return $res
}
# ------------------------------------------------------------------------------
proc gamma { var } {
global PI
set var [expr $var+1.0]
if {$var >= 0.0} {
set step 0.01
set res 0.0
for {set ii -20.0} {$ii <= 20.0 + $var} {set ii [expr $ii + $step]} {
set old $res
set res [expr $res + (exp($var*$ii)*exp(-exp($ii))*$step)]
if {$old == $res} {break}
}
set ret $res
} else {
if {[expr abs($var - int($var))] > 0} {
set var [expr abs($var)]
set ret [gamma [expr $var-1.0]]
set ret [expr -$PI/($var*$ret*sin($PI*$var))]
} else {
error "" "" {ARITH OVERFLOW}
}
}
return $ret
}
# ------------------------------------------------------------------------------
proc func_faculty {} {
global stack
if {$stack(x) < 0.0 || [expr abs($stack(x) - int($stack(x)))] > 0} {
set stack(x) [gamma $stack(x)]
} else {
set stack(x) [faculty $stack(x)]
}
}
# ------------------------------------------------------------------------------
proc func_avg {} {
global HP15 status stack storage
if {$HP15(dataregs) < 7} {
error "" "" {INDEX}
} elseif {abs($storage(2)) > 0.0} {
lift
if {!$status(liftlock)} {lift}
set stack(y) [expr $storage(5)/$storage(2)]
set istack(y) 0.0
set stack(x) [expr $storage(3)/$storage(2)]
set istack(x) 0.0
} else {
error "" "" {SUM}
}
}
# ------------------------------------------------------------------------------
proc func_linexpolation {} {
global HP15 status stack storage
if {$HP15(dataregs) < 7} {
error "" "" {INDEX}
} elseif {abs($storage(2)) >= 1} {
lift
if {!$status(liftlock)} {lift}
set M [expr $storage(2)*$storage(4)-$storage(3)*$storage(3)]
set N [expr $storage(2)*$storage(6)-$storage(5)*$storage(5)]
set P [expr $storage(2)*$storage(7)-$storage(3)*$storage(5)]
set stack(x) [expr ($M*$storage(5) + \
$P*($storage(2)*$stack(x) - $storage(3)) ) / ($storage(2)*$M)]
set istack(x)
set stack(y) [expr $P/sqrt($M*$N)]
set istack(y)
} else {
error "" "" {SUM}
}
}
# ------------------------------------------------------------------------------
proc func_linreg {} {
global HP15 status stack storage
if {$HP15(dataregs) < 7} {
error "" "" {INDEX}
} elseif {abs($storage(2)) >= 1} {
lift
if {!$status(liftlock)} {lift}
set M [expr $storage(2)*$storage(4)-$storage(3)*$storage(3)]
set N [expr $storage(2)*$storage(6)-$storage(5)*$storage(5)]
set P [expr $storage(2)*$storage(7)-$storage(3)*$storage(5)]
set stack(y) [expr $P/$M]
set istack(y) 0.0
set stack(x) [expr ($M*$storage(5) - $P*$storage(3))/($storage(2)*$M)]
set istack(x) 0.0
} else {
error "" "" {SUM}
}
}
# ------------------------------------------------------------------------------
proc func_stddev {} {
global HP15 status stack storage
if {$HP15(dataregs) < 7} {
error "" "" {INDEX}
} elseif {abs($storage(2)) > 0.0} {
lift
if {!$status(liftlock)} {lift}
set DIVISOR [expr $storage(2)*($storage(2)-1.0)]
set stack(y) \
[expr sqrt(($storage(2)*$storage(6)-$storage(5)*$storage(5))/$DIVISOR)]
set istack(y) 0.0
set stack(x) \
[expr sqrt(($storage(2)*$storage(4)-$storage(3)*$storage(3))/$DIVISOR)]
set istack(x) 0.0
} else {
error "" "" {SUM}
}
}
# ------------------------------------------------------------------------------
proc func_sum_plus {} {
global HP15 status stack storage
if {$HP15(dataregs) < 7} {
error "" "" {INDEX}
} else {
set storage(2) [expr $storage(2) + 1]
set storage(3) [expr $storage(3) + $stack(x)]
set storage(4) [expr $storage(4) + $stack(x)*$stack(x)]
set storage(5) [expr $storage(5) + $stack(y)]
set storage(6) [expr $storage(6) + $stack(y)*$stack(y)]
set storage(7) [expr $storage(7) + $stack(x)*$stack(y)]
set stack(x) $storage(2)
set status(liftlock) 2
}
}
# ------------------------------------------------------------------------------
proc func_sum_minus {} {
global HP15 status stack storage
if {$HP15(dataregs) < 7} {
error "" "" {INDEX}
} else {
set storage(2) [expr $storage(2) - 1]
set storage(3) [expr $storage(3) - $stack(x)]
set storage(4) [expr $storage(4) - $stack(x)*$stack(x)]
set storage(5) [expr $storage(5) - $stack(y)]
set storage(6) [expr $storage(6) - $stack(y)*$stack(y)]
set storage(7) [expr $storage(7) - $stack(x)*$stack(y)]
set stack(x) $storage(2)
set status(liftlock) 2
}
}
# ------------------------------------------------------------------------------
proc func_Pyx {} {
global stack
if {[expr $stack(x) - int($stack(x))] > 0 || $stack(x) < 0 || \
[expr $stack(y) - int($stack(y))] > 0 || $stack(y) < 0 || \
[expr $stack(x) > $stack(y)]} {
error "" "" {ARITH INVALID}
} else {
set stack(y) [expr [faculty $stack(y)]/ \
[faculty [expr int($stack(y)-$stack(x))]]]
drop
}
}
# ------------------------------------------------------------------------------
proc func_Cyx {} {
global stack
if {[expr $stack(x) - int($stack(x))] > 0 || $stack(x) < 0 || \
[expr $stack(y) - int($stack(y))] > 0 || $stack(y) < 0 || \
[expr $stack(x) > $stack(y)]} {
error "" "" {ARITH INVALID}
} else {
set stack(y) [expr [faculty $stack(y)]/ \
([faculty $stack(x)]*[faculty [expr int($stack(y)-$stack(x))]])]
drop
}
}
# ------------------------------------------------------------------------------
proc func_enter {} {
global status FLAG stack istack
if {[string first "." "$stack(x)"] == -1 && \
[string first "e" "$stack(x)"] == -1} {
append stack(x) "."
}
if {$FLAG(8) && [string first "." "$stack(x)"] == -1 && \
[string first "e" "$stack(x)"] == -1} {
append istack(x) "."
}
lift
set status(liftlock) 2
show_x
}
# ------------------------------------------------------------------------------
proc func_lastx {} {
global status FLAG stack istack
lift
set stack(x) $stack(LSTx)
if {$FLAG(8)} {set istack(x) $istack(LSTx)}
}
# ------------------------------------------------------------------------------
proc func_rectangular {} {
global status FLAG stack istack
if {$FLAG(8)} {
set stack(x) [expr cos($istack(x)*$status(RADfactor))*$stack(x)]
set istack(x) [expr sin($istack(x)*$status(RADfactor))*$stack(s)]
} else {
set stack(x) [expr cos($stack(y)*$status(RADfactor))*$stack(x)]
set stack(y) [expr sin($stack(y)*$status(RADfactor))*$stack(s)]
}
}
# ------------------------------------------------------------------------------
proc func_hms {} {
global stack
set hours [expr int($stack(x))]
set minutes [expr int(($stack(x) - $hours)*60.0)/100.0]
set seconds [expr ($stack(x) - $hours - $minutes*60.0/36.0)*0.36]
set stack(x) [expr $hours + $minutes + $seconds]
}
# ------------------------------------------------------------------------------
proc func_h {} {
global stack
set hours [expr int($stack(x))]
set minutes [expr int(($stack(x) - $hours)*100.0)]
set seconds [expr ($stack(x) - $hours - $minutes/100.0)*10000.0]
set stack(x) [expr $hours + ($minutes*60+$seconds)/3600.0]
}
# ------------------------------------------------------------------------------
proc func_rad {} {
global stack PI
set stack(x) [expr $stack(x)*$PI/180.0]
}
# ------------------------------------------------------------------------------
proc func_deg {} {
global stack PI
set stack(x) [expr $stack(x)*180.0/$PI]
}
# ------------------------------------------------------------------------------
proc func_re_im {} {
global FLAG stack istack
if {!$FLAG(8)} {func_sf 8}
set tmp $stack(x)
set stack(x) $istack(x)
set istack(x) $tmp
}
# ------------------------------------------------------------------------------
proc show_test_options { trigger } {
global LAYOUT status TEST
if {$status(PRGM)} {
if {[winfo exists .testops]} {destroy .testops}
menu .testops -tearoff 0 -title "Test" -font $LAYOUT(FnMenu)
for {set ii 0} {$ii <= 9} {incr ii} {
.testops add command -label "$ii: [lindex $TEST $ii]" \
-command "dispatch_key 43_30_$ii" -underline 0
}
if {$trigger == 3} {
tk_popup .testops [winfo pointerx .] [winfo pointery .]
} else {
tk_popup .testops [winfo rootx .btn_310.gbtn] \
[expr [winfo rooty .btn_310.gbtn]+[winfo height .btn_310.gbtn]]
}
}
}
# ------------------------------------------------------------------------------
proc func_test { op } {
global status FLAG stack istack prgstat PRGM
if {$prgstat(running)} {
switch $op {
0 {if {$FLAG(8)} {
set rc [expr $stack(x) != 0.0 || $istack(x) != 0.0]
} else {
set rc [expr $stack(x) != 0.0]
}
}
1 {set rc [expr $stack(x) > 0.0]}
2 {set rc [expr $stack(x) < 0.0]}
3 {set rc [expr $stack(x) >= 0.0]}
4 {set rc [expr $stack(x) <= 0.0]}
5 {if {$FLAG(8)} {
set rc [expr $stack(x) == $stack(y) && $istack(x) == $istack(y) ]
} else {
set rc [expr $stack(x) == $stack(y)]
}
}
6 {if {$FLAG(8)} {
set rc [expr $stack(x) != $stack(y) || $istack(x) != $istack(y) ]
} else {
set rc [expr $stack(x) != $stack(y)]
}
}
7 {set rc [expr $stack(x) > $stack(y)]}
8 {set rc [expr $stack(x) < $stack(y)]}
9 {set rc [expr $stack(x) >= $stack(y)]}
10 {set rc [expr $stack(x) <= $stack(y)]}
11 {if {$FLAG(8)} {
set rc [expr $stack(x) == 0.0 && $istack(x) == 0.0]
} else {
set rc [expr $stack(x) == 0.0]
}
}
}
if {!$rc} {
if {$prgstat(curline) < [llength $PRGM]} {incr prgstat(curline) 2}
}
} else {
show_x
}
}
# ------------------------------------------------------------------------------
proc func_plus {} {
global FLAG stack istack
set stack(y) [expr $stack(y) + (1.0 * $stack(x))]
if {$FLAG(8)} {set istack(y) [expr $istack(y) + (1.0 * $istack(x))]}
drop
}
# ------------------------------------------------------------------------------
proc func_minus {} {
global FLAG stack istack
set stack(y) [expr $stack(y) - $stack(x)]
if {$FLAG(8)} {set istack(y) [expr $istack(y) - (1.0 * $istack(x))]}
drop
}
# ------------------------------------------------------------------------------
proc func_mult {} {
global FLAG stack istack
if {$FLAG(8)} {
set tmp $stack(y)
set stack(y) [expr $stack(x)*$stack(y) - $istack(x)*$istack(y)]
set istack(y) [expr $stack(x)*$istack(y) + $istack(x)*$tmp]
} else {
set stack(y) [expr 1.0 * $stack(x) * $stack(y)]
}
drop
}
# ------------------------------------------------------------------------------
proc func_div {} {
global FLAG stack istack
if {$FLAG(8)} {
set tmp $stack(y)
set divi [expr $stack(x)*$stack(x) + $istack(x)*$istack(x)]
set stack(y) [expr ($stack(x)*$stack(y) + $istack(x)*$istack(y))/$divi]
set istack(y) [expr ($stack(x)*$istack(y) - $tmp*$istack(x))/$divi]
} else {
set stack(y) [expr $stack(y) / (1.0 * $stack(x))]
}
drop
}
# ------------------------------------------------------------------------------
proc lookup_keyname { mod code } {
global status HP15_KEYS TEST
set kname $code
switch $mod {
"f DIM" -
"STO +" -
"STO -" -
"STO \u00D7" -
"STO \u00F7" -
"STO" -
"RCL +" -
"RCL -" -
"RCL \u00D7" -
"RCL \u00F7" -
"RCL" {
set ind [expr [lsearch {24 25} $code] == -1 ? 5 : 4]
}
"GTO" -
"GSB" -
"f LBL" {
set ind [expr [lsearch {11 12 13 14 15 25} $code] == -1 ? 5 : 4]
}
"f DSE" -
"f ISG" -
"f FIX" {
set ind [expr (($code == 25) | ($code == 24)) ? 4 : 5]
}
"f" {
set ind 4
}
"g" {
set ind 6
}
"g TEST" {
return [string map {" " ""} [lindex $TEST $code]]
}
"g SF" -
"g CF" -
"g F?" {
set ind [expr $code == 25 ? 4 : 5]
}
default {
set ind 5
}
}
foreach kk $HP15_KEYS {
if {[lindex $kk 3] == $code} {
set kname [lindex $kk $ind]
break
}
}
return $kname
}
# ------------------------------------------------------------------------------
proc build_mnemonic { step wid } {
set rc {}
while {[regexp {([0-9][0-9]?)_?(.*)} $step all key rest]} {
set step $rest
lappend rc [lookup_keyname [join $rc] $key]
}
return [format "%$wid\s" [string map {". " "."} [join $rc]]]
}
# ------------------------------------------------------------------------------
proc show_prgm { trigger } {
global LAYOUT HP15 status prgstat PRGM
if {[winfo exists .program]} {destroy .program}
menu .program -tearoff 0 -title "Program" -font $LAYOUT(FnMenu)
for {set ii 0} {$ii < [llength $PRGM]} {incr ii} {
set cs [lindex $PRGM $ii]
if {$HP15(mnemonics)} {
set lbl "[format "%03d" $ii]-[build_mnemonic $cs 10]"
} else {
set lbl "[format_prgm $ii 9]"
}
if {$status(PRGM)} {
set cmd "set prgstat(curline) $ii\nshow_curline"
} else {
set cmd "set prgstat(curline) $ii"
}
.program add command -label "$lbl" -command $cmd
if {$HP15(prgmmenubreak) && $ii % $HP15(prgmmenubreak) == 0} {
.program entryconfigure $ii -columnbreak 1
}
if {$HP15(prgmcoloured)} {
if {[string first "42_21" $cs] == 0} {
.program entryconfigure $ii -foreground $LAYOUT(fbutton_bg) \
-background $LAYOUT(button_bg)
}
if {[string first "43_32" $cs] == 0} {
.program entryconfigure $ii -foreground $LAYOUT(gbutton_bg) \
-background $LAYOUT(button_bg)
}
if {[string first "22_" $cs] == 0 || [string first "32_" $cs] == 0} {
.program entryconfigure $ii -foreground white \
-background $LAYOUT(button_bg)
}
}
}
if {$trigger == 3} {
tk_popup .program [winfo pointerx .] [winfo pointery .]
} else {
tk_popup .program [winfo rootx .status] \
[expr [winfo rooty .status] + [winfo height .status]]
}
}
# ------------------------------------------------------------------------------
proc show_curline {} {
global curdisp prgstat
set curdisp " [format_prgm $prgstat(curline) 6]"
}
# ------------------------------------------------------------------------------
proc prgm_addstep { step } {
global HP15 prgstat PRGM
if {$HP15(prgmregsfree) + $HP15(freebytes) > 0} {
set PRGM [linsert $PRGM [expr $prgstat(curline)+1] $step]
incr prgstat(curline)
show_curline
mem_recalc
} else {
error_handler ADDRESS
}
}
# ------------------------------------------------------------------------------
proc prgm_interrupt {} {
global status prgstat
set status(solve) 0
set status(integrate) 0
set prgstat(interrupt) 1
}
# ------------------------------------------------------------------------------
proc prgm_step {} {
global status prgstat PRGM
set oldline $prgstat(curline)
dispatch_key [lindex $PRGM $prgstat(curline)]
if {$prgstat(curline) == 0} {
set prgstat(running) 0
} elseif {$prgstat(curline) == [llength $PRGM]} {
# Implicit return at end of program code
if {$oldline == $prgstat(curline)} {
dispatch_key 43_32
dispatch_key [lindex $PRGM $prgstat(curline)]
}
} else {
if {$oldline == $prgstat(curline) && !$status(error)} {
incr prgstat(curline)
}
}
}
# ------------------------------------------------------------------------------
proc prgm_run { start } {
global HP15 stack curdisp status prgstat
# disable stack tracing for smoother display updates and performance reasons
trace vdelete stack(x) w show_x
# any key or button event will interrupt a running program
grab .logo
focus .logo
bind .logo <KeyPress> {prgm_interrupt}
bind .logo <ButtonPress> {prgm_interrupt}
set iter 0
set status(num) 1
set prgstat(running) 1
set prgstat(curline) $start
while {$prgstat(running)} {
if {$curdisp == ""} {
set curdisp " running"
} else {
set curdisp ""
}
update
after $HP15(delay)
prgm_step
if {[incr iter]> $prgstat(maxiter)} {set prgstat(running) 0}
if {$prgstat(interrupt)} {set prgstat(running) 0}
}
# re-enable tracing on stack(x) and reset interrupt handling
trace variable stack(x) w show_x
grab release .logo
focus .
set status(num) 1
if {$prgstat(interrupt)} {
error "" "" {INTERRUPT}
} elseif {!$status(error)} {
show_x
}
}
# ------------------------------------------------------------------------------
proc func_pse {} {
global HP15 status
if {!$status(PRGM)} {
show_x
update
after $HP15(pause)
}
}
# ------------------------------------------------------------------------------
proc func_rs {} {
global prgstat
if {$prgstat(running)} {
set prgstat(running) 0
update
} else {
if {$prgstat(curline) == 0} {incr prgstat(curline)}
prgm_run $prgstat(curline)
}
}
# ------------------------------------------------------------------------------
proc func_pr {} {
global status FLAG
set_status PRGM
if {$status(PRGM)} {
set FLAG(9) 0
show_curline
} else {
set status(num) 1
show_x
}
}
# ------------------------------------------------------------------------------
proc func_rtn {} {
global prgstat
set prgstat(curline) [lindex $prgstat(rtnadr) end]
if {[llength $prgstat(rtnadr)] > 1} {
set prgstat(rtnadr) [lreplace $prgstat(rtnadr) end end]
}
}
# ------------------------------------------------------------------------------
proc func_on {} {
global APPDATA
set answer [tk_messageBox -type okcancel -icon question -default ok \
-title $APPDATA(titlewide) \
-message "Exit Tcl/Tk $APPDATA(title) Simulator?"]
if {"$answer" == "ok"} {exit_handler}
}
# ------------------------------------------------------------------------------
proc lookup_keyseq { keyseq by_func } {
global HP15_KEY_FUNCS
set rc ""
set ind [lsearch {0 42 43 44 45} [string range $keyseq 0 1]]
if {$ind == -1} {set ind 0}
set funclist [lindex $HP15_KEY_FUNCS $ind]
if {$by_func == 1} {
foreach ff $funclist {
if {[regexp "^[lindex $ff 0]\$" $keyseq]} {
set rc $ff
break
}
}
} else {
foreach ff $funclist {
if {[string match "$keyseq\_*" $ff]} {
set rc $ff
break
}
}
}
return $rc
}
# ------------------------------------------------------------------------------
proc check_attributes { func num } {
global status stack
# Numbers with leading zeros are interpreted as octal number by the Tcl/Tk
# interpreter. Must manipulate stack(x) value for most of the functions.
if {!$status(num)} {
if {$stack(x) != 0.0 &&
[lsearch {func_bs func_chs func_digit} $func] == -1} {
regsub {^\-0+} $stack(x) {-} tmp
regsub {^0+} $tmp {} stack(x)
}
}
move x s
if {$num} {set status(num) 1}
}
# ------------------------------------------------------------------------------
proc dispatch_key { kcode args } {
global status FLAG isseq keyseq errorCode
set fmatch ""
set svar ""
if {$status(error)} {
set status(error) 0
if {$status(PRGM)} {
show_curline
} else {
show_x
}
return
}
if {$keyseq != ""} {
if {[string match {4[23]} $kcode] && [string match {4[23]} $keyseq]} {
set keyseq $kcode
} else {
set_status fg_off
set keyseq $keyseq\_$kcode
# This will allow abbreviated key sequences
regsub {_4[23]} $keyseq "" keyseq
}
} else {
set keyseq $kcode
}
set fmatch [lookup_keyseq $keyseq 1]
if {$fmatch != ""} {
# Key sequence matches a function
foreach {kseq func alstx anum aprgm} $fmatch {
regexp $kseq$ $keyseq mvar svar
if {$status(PRGM) && $aprgm} {
prgm_addstep $keyseq
} else {
set keyseq ""
check_attributes [lindex $func 0] $anum
# This is where all func_tions are executed
if {[catch {
# Args are not passed through if we have a sequence.
if {$isseq} {
eval $func$svar
} else {
eval $func$svar $args
}
}]} {error_handler $errorCode}
if {!$status(error) && $status(num) && $alstx} {move s LSTx}
}
}
set keyseq ""
if {$aprgm && $status(liftlock)} {incr status(liftlock) -1}
} else {
# If key sequence doesn´t match exactly check for longer one.
set seq [lookup_keyseq $keyseq 0]
# Sequence doesn´t match. Start new sequence with last key typed in.
if {$seq == "" && $kcode != ""} {
set keyseq ""
set isseq 0
if {$status(f)} {set kcode 42_$kcode}
if {$status(g)} {set kcode 43_$kcode}
if {"$args" == ""} {
dispatch_key $kcode
} else {
dispatch_key $kcode $args
}
} else {
set isseq 1
}
}
}
# ------------------------------------------------------------------------------
proc check_on_num {len name el op} {
global $name ${name}_oldval
if {[string compare $el {}]} {
set old ${name}_oldval\($el)
set name $name\($el)
} else {
set old ${name}_oldval
}
if {([string length [set $name]] > $len) || \
[regexp {^[0-9]*$} [set $name]] == 0} {
set $name [set $old]
} else {
set $old [set $name]
}
}
# ------------------------------------------------------------------------------
proc isInt { ii len } {
# return [regexp {^[1234567890]*$} "$ii"]
expr {[string is integer $ii] && [string length [string trim $ii]] <= $len}
}
# ------------------------------------------------------------------------------
proc browser_lookup {} {
global APPDATA
set bl {}
foreach bw $APPDATA(browserlist) {
set bwf [auto_execok $bw]
if [string length $bwf] { lappend bl "$bw" "$bwf" }
}
return $bl
}
# ------------------------------------------------------------------------------
proc browser_select { wid browser } {
global APPDATA
set nbw [tk_getOpenFile -parent .prefs -initialdir "[file dirname $browser]" \
-title "$APPDATA(title): Select help file browser" \
-filetypes $APPDATA(exetypes)]
if {[string length $nbw] > 0} {
$wid configure -state normal
$wid delete 0 end
$wid insert 0 $nbw
$wid xview end
$wid configure -state disabled
}
}
# ------------------------------------------------------------------------------
proc fontset_apply { fsn } {
global LAYOUT FONTSET HP15
set fslist [lindex $FONTSET $fsn]
foreach {fs fnt} [lindex $fslist 1] {
set LAYOUT($fs) $fnt
}
}
# ------------------------------------------------------------------------------
proc preferences_apply { andExit ww } {
global APPDATA HP15 HP15tmp PREFTEXT
set prefs_ok true
foreach vv {prgmmenubreak pause delay} {
if {[string length [string trim $HP15tmp($vv)]] == 0} {
tk_messageBox -type ok -icon error -default ok -title $APPDATA(titlewide) \
-message "Invalid settings for '$PREFTEXT($vv)'."
set prefs_ok false
break
}
}
if {$prefs_ok} {
array set HP15 [array get HP15tmp]
if {$andExit} {destroy $ww}
}
}
# ------------------------------------------------------------------------------
proc preferences {} {
global APPDATA HP15 HP15tmp FONTSET PREFTEXT
array set HP15tmp [array get HP15]
if [winfo exists .pre
fs] {
place forget .prefs
} else {
toplevel .prefs
frame .prefs.outer -relief flat
# Calculator and OS settings
set fpo .prefs.outer.hp15
labelframe $fpo -relief groove -borderwidth 2 -text $PREFTEXT(frm_os)
checkbutton $fpo.clpbrdc -text $PREFTEXT(clpbrdc) \
-variable HP15tmp(clpbrdc) -indicatoron 1
checkbutton $fpo.mnemonics -text $PREFTEXT(mnemonics) \
-variable HP15tmp(mnemonics) -indicatoron 1
checkbutton $fpo.prgmcoloured -text $PREFTEXT(prgmcoloured) \
-variable HP15tmp(prgmcoloured) -indicatoron 1
frame $fpo.prgm
label $fpo.prgm.label -text $PREFTEXT(prgmmenubreak) -anchor w
spinbox $fpo.prgm.sb -width 2 -justify right -from 5 -to 45 -increment 1\
-textvariable HP15tmp(prgmmenubreak) -validate all -vcmd "isInt %P 2"
checkbutton $fpo.breakstomenu -text $PREFTEXT(breakstomenu) \
-variable HP15tmp(breakstomenu) -indicatoron 1
checkbutton $fpo.prgmstounicode -text $PREFTEXT(prgmstounicode) \
-variable HP15tmp(prgmstounicode) -indicatoron 1
pack $fpo.prgm.label -side left
pack $fpo.prgm.sb -side right -padx 5
pack $fpo.clpbrdc $fpo.mnemonics $fpo.prgmcoloured -anchor nw -padx 10
pack $fpo.prgm -side top -anchor nw -expand no -fill x -padx 10
pack $fpo.breakstomenu $fpo.prgmstounicode -side top -anchor nw -padx 10
# Behaviour
set fpo .prefs.outer.behave
labelframe $fpo -relief groove -borderwidth 2 -text $PREFTEXT(frm_simulator)
checkbutton $fpo.behaviour -text $PREFTEXT(strictHP15) \
-variable HP15tmp(strictHP15) -indicatoron 1 -state disabled
checkbutton $fpo.saveonexit -text $PREFTEXT(saveonexit) \
-variable HP15tmp(saveonexit)
frame $fpo.pause
label $fpo.pause.label -text $PREFTEXT(pause) \
-anchor w
spinbox $fpo.pause.sb -width 4 -justify right -from 0 -to 2000 \
-increment 1 -textvariable HP15tmp(pause) -validate all -vcmd "isInt %P 4"
frame $fpo.delay
label $fpo.delay.label -text $PREFTEXT(delay) -anchor w
spinbox $fpo.delay.sb -width 3 -justify right -from 0 -to 999 \
-increment 1 -textvariable HP15tmp(delay) -validate all -vcmd "isInt %P 3"
pack $fpo.behaviour $fpo.saveonexit -side top -anchor w -padx 5
pack $fpo.pause.label -side left
pack $fpo.pause.sb -side right -padx 5
pack $fpo.delay.label -side left
pack $fpo.delay.sb -side right -padx 5
pack $fpo.pause $fpo.delay -expand yes -fill both -side top \
-anchor w -padx 5 -pady 2
# Font settings
set fpo .prefs.outer.fontset
labelframe $fpo -relief groove -borderwidth 2 -text $PREFTEXT(frm_fontset)
set dpi [expr round([tk scaling]*72)]
label $fpo.info -anchor nw -justify left \
-text "Available font sets for $::tcl_platform(os) at $dpi dpi:"
frame $fpo.fs
set fsn 0
foreach fs $FONTSET {
set cfs [lindex $fs 0]
if {$::tcl_platform(platform) == [lindex $cfs 0] && \
$dpi >= [lindex $cfs 2] && $dpi <= [lindex $cfs 3]} {
radiobutton $fpo.fs.$fsn -text "[lindex $cfs 1]" -value $fsn \
-variable HP15tmp(fontset)
pack $fpo.fs.$fsn -side top -anchor w -padx 10
}
incr fsn
}
label $fpo.hint -anchor nw -justify left -text $PREFTEXT(fonthint)
pack $fpo.info $fpo.fs $fpo.hint -side top -anchor w -expand no -fill x \
-padx 10
# Browser settings
set fpo .prefs.outer.browser
labelframe $fpo -relief groove -borderwidth 2 -text $PREFTEXT(browser)
frame $fpo.bw
foreach {bw bwf} [browser_lookup] {
radiobutton $fpo.bw.$bw -text "$bw" -value "$bwf" \
-variable HP15tmp(browser)
pack $fpo.bw.$bw -side top -anchor w -padx 10
}
button $fpo.sel -text "Browse\u2026" \
-anchor w -borderwidth 1 -highlightthickness 0 \
-command "browser_select {$fpo.entry} {$HP15tmp(browser)}"
entry $fpo.entry -width 32 -justify left -textvariable HP15tmp(browser)
pack $fpo.bw -side top -anchor w
pack $fpo.sel -side left -padx 10 -anchor n
pack $fpo.entry -side left -anchor n
# Lay out dialogue
set fpo .prefs.outer
grid $fpo.hp15 -column 0 -row 0 -sticky nsew -padx 3 -pady 3
grid $fpo.behave -column 0 -row 1 -sticky nsew -padx 3 -pady 3
grid $fpo.fontset -column 1 -row 0 -sticky nsew -padx 3 -pady 3
grid $fpo.browser -column 1 -row 1 -sticky nsew -padx 3 -pady 3
pack .prefs.outer -side top
set fbtn .prefs.btn
frame $fbtn -relief flat
button $fbtn.ok -text "OK" -width 6 -default active \
-command "preferences_apply true .prefs"
button $fbtn.apply -text "Apply" -width 6 \
-command "preferences_apply false .prefs"
button $fbtn.cancel -text "Cancel" -width 6 -command "destroy .prefs"
pack $fbtn.cancel $fbtn.apply $fbtn.ok -side right -padx 5 -anchor e
pack $fbtn -in .prefs -side top -expand no -fill x -pady 5
wm title .prefs "$APPDATA(title): Preferences"
wm transient .prefs .
wm resizable .prefs false false
wm geometry .prefs +[expr [winfo x .]+10]+[expr [winfo y .]+10]
bind .prefs <Return> "preferences_apply true .prefs"
bind .prefs <Escape> "destroy .prefs"
raise .prefs
focus .prefs
}
}
# ------------------------------------------------------------------------------
proc exit_handler {} {
global HP15 status FLAG prgstat
if {$HP15(saveonexit)} {
if {$status(error)} {func_clx}
set status(error) 0
set status(f) 0
set status(g) 0
set status(num) 1
set status(solve) 0
set status(integrate) 0
set status(PRGM) 0
set prgstat(interrupt) 0
set prgstat(running) 0
set FLAG(9) 0
mem_save
}
destroy .
}
# ------------------------------------------------------------------------------
proc about {} {
global APPDATA LAYOUT
if [winfo exists .about] {destroy .about}
toplevel .about
wm title .about "About: $APPDATA(title) Simulator"
frame .about.frm1 -background $LAYOUT(display_outer_frame) -relief sunken \
-borderwidth 2
frame .about.frm2 -background $LAYOUT(display_inner_frame) -relief sunken \
-borderwidth 2
frame .about.frm3 -background $LAYOUT(display) -relief sunken \
-borderwidth 2
text .about.text -background $LAYOUT(display) -height 26 -width 65 \
-relief flat -font $LAYOUT(FnButton) -highlightthickness 0
frame .about.bfrm -background $LAYOUT(keypad_bg) -relief sunken -height 20
button .about.bfrm.off -text "OK" -default active -font $LAYOUT(FnButton) \
-background $LAYOUT(button_bg) -foreground white -command "destroy .about" \
-width $LAYOUT(BtnWidth) -borderwidth 2 \
.about.text insert 0.0 "\n$APPDATA(titlewide)\n\nA Simulator written in Tcl/Tk" \
Ttitle
.about.text tag configure Ttitle -font $LAYOUT(FnButton) -justify center
set text "\n\n$APPDATA(copyright)\n\nSerial No. $APPDATA(SerialNo)\n"
.about.text insert end $text copyright
.about.text tag configure copyright -font $LAYOUT(FnButton) -justify center
.about.text insert end "\n[string repeat "_" 65]\n" seperator
.about.text tag configure seperator -font $LAYOUT(FnButton) -justify center
set text "\nThis program is free software; you can redistribute it and/or\
modify it under the terms of the GNU General Public License as published by \
the Free Software Foundation; either version 2 of the License, or any later\
version.\n\n\This program is distributed in the hope that it will be useful,\
but without any warranty; without even the implied warranty of merchantability \
or fitness for a particular purpose. See the GNU General Public License for \
more details."
.about.text insert end $text warranty
.about.text tag configure warranty -font $LAYOUT(FnButton) -justify left \
-wrap word
.about.text insert end "\n[string repeat "_" 65]\n" seperator
.about.text tag configure seperator -font $LAYOUT(FnButton) -justify center
set text "\nThis program is not a Hewlett-Packard product.\n
HP and the HP logo are trademarks of Hewlett-Packard."
.about.text insert end $text warranty
.about.text tag configure warranty -font $LAYOUT(FnButton) -justify left \
-wrap word
.about.text configure -state disabled
pack .about.text -in .about.frm3 -side top -expand no -fill x -padx 10
pack .about.frm3 -in .about.frm2 -side top -expand no -padx 14 -pady 0
pack .about.frm2 -in .about.frm1 -side left -expand yes
pack .about.frm1 -in .about -side top -expand yes -fill x \
-ipadx 10 -ipady 10
pack .about.bfrm.off -in .about.bfrm -side right -expand no -fill none \
-padx 15 -pady 10
pack .about.bfrm -in .about -side top -expand no -fill x
wm resizable .about false false
wm geometry .about +[expr [winfo x .]+15]+[expr [winfo y .]+10]
wm transient .about .
bind .about <Return> "destroy .about"
bind .about <Escape> "destroy .about"
raise .about
grab .about
focus .about
}
# ------------------------------------------------------------------------------
proc key_event { kname code } {
if {[.btn_$kname.btn cget -relief] == "raised"} {
.btn_$kname.btn configure -relief sunken
.btn_$kname.gbtn configure -relief flat
after 100 "
.btn_$kname.btn configure -relief raised
.btn_$kname.gbtn configure -relief raised
"
dispatch_key $code
}
}
# ------------------------------------------------------------------------------
proc key_press { kname code ev } {
global isseq
.btn_$kname.btn configure -relief sunken
.btn_$kname.gbtn configure -relief flat
dispatch_key $code $ev
}
# ------------------------------------------------------------------------------
proc key_release { kname code ev } {
global isseq
.btn_$kname.btn configure -relief raised
.btn_$kname.gbtn configure -relief raised
# Do not execute release event if key is part of a sequence.
if {!$isseq} {dispatch_key $code $ev}
}
# ------------------------------------------------------------------------------
proc kp_key_press { state kcode } {
# Dispatch key-pad key as digit key if NumLock is on.
if {[expr $state & 16] == 16} {
dispatch_key $kcode
}
}
# ------------------------------------------------------------------------------
proc hp_key { kname utext mtext ltext kcode fbnd bnd gbnd} {
global LAYOUT
frame .btn_$kname -relief flat -background $LAYOUT(keypad_bg)
# upper (yellow) function
label .btn_$kname.fbtn -text $utext -anchor center -font $LAYOUT(FnFGBtn) \
-foreground $LAYOUT(fbutton_bg) -background $LAYOUT(keypad_bg) \
-borderwidth 0 -highlightthickness 0
if {$utext != ""} {
bind .btn_$kname.fbtn "<Button-1>" "key_event $kname 42_$kcode"
}
foreach kk $fbnd {
bind . <$kk> "key_event $kname 42_$kcode"
}
# basic function
label .btn_$kname.btn -relief raised -width $LAYOUT(BtnWidth) -text $mtext \
-anchor center -font $LAYOUT(FnButton) -foreground white \
-background $LAYOUT(button_bg) -borderwidth 2 -foreground white \
-highlightbackground $LAYOUT(button_bg) -highlightthickness 0
bind .btn_$kname.btn "<Button-1>" "key_event $kname $kcode"
foreach kk $bnd {
if {[string is digit $kk]} {
bind . <Key-$kk> "key_event $kname $kcode"
} else {
bind . <$kk> "key_event $kname $kcode"
}
}
# lower (blue) function
label .btn_$kname.gbtn -text $ltext -anchor center -relief raised \
-font $LAYOUT(FnFGBtn) -foreground $LAYOUT(gbutton_bg) \
-background $LAYOUT(button_bg) \
-borderwidth 1 -highlightthickness 0 -width $LAYOUT(BtnWidth)
if {$ltext != ""} {
bind .btn_$kname.gbtn "<Button-1>" "key_event $kname 43_$kcode"
}
foreach kk $gbnd {
bind . <$kk> "key_event $kname 43_$kcode"
}
pack .btn_$kname.fbtn -side top -expand no -fill x
if {$ltext == ""} {
pack .btn_$kname.btn -side top -expand no -fill both -padx 7
} else {
pack .btn_$kname.btn -side top -expand no -fill both -padx 7
pack .btn_$kname.gbtn -side top -expand no -fill x -padx 7
}
return .btn_$kname
}
# ------------------------------------------------------------------------------
proc gui_draw {} {
global LAYOUT HP15_KEYS HP15 digits dwidth dheight
# Layout display and logo
fontset_apply $HP15(fontset)
. configure -background $LAYOUT(keypad_bg)
set dwid 18
set swid [expr int($dwid * 0.5)]
set ypos 8
set dspheight [ expr round($dheight * 1.35) ]
frame .dframe1 -background $LAYOUT(display_outer_frame) -relief sunken \
-borderwidth 2
frame .dframe2pad -background $LAYOUT(display_outer_frame) -relief sunken \
-borderwidth 0
frame .dframe2 -background $LAYOUT(display_inner_frame) -relief sunken \
-borderwidth 2
frame .dframe3 -background $LAYOUT(display) -relief sunken -borderwidth 3
canvas .display -background $LAYOUT(display) -highlightthickness 0 \
-width [expr $dwidth*$digits] -height $dspheight
set id [.display create text 0 $ypos -font $LAYOUT(FnDisplay) -anchor nw]
.display addtag d0 withtag $id
for {set ii 1} {$ii < 11} {incr ii} {
set jj [expr $ii-1]
set id [.display create text [expr $dwid*$ii + $swid*$jj] $ypos \
-font $LAYOUT(FnDisplay) -anchor nw]
.display addtag d$ii withtag $id
set id [.display create text [expr $dwid*($ii+1) + $swid*$jj] $ypos \
-font $LAYOUT(FnDisplay) -anchor nw]
.display addtag p$ii withtag $id
}
# Calculate positions for status display
canvas .status -background $LAYOUT(display) -highlightthickness 0 \
-width [expr $dwid+($dwid+$swid)*10] \
-height [expr [font actual $LAYOUT(FnStatus) -size] * 2]
set ypos 0
foreach {tname xpos} {user 1.4 f 2.25 g 3.0 begin 4.6 rad 6.4 dmy 7.2 \
complex 8.25 prgm 9.9} {
set id [.status create text [expr $dwid + ($dwid + $swid)*$xpos] $ypos \
-font $LAYOUT(FnDisplay) -anchor ne]
.status addtag s$tname withtag $id
}
.status itemconfigure all -font $LAYOUT(FnStatus)
pack .display .status -in .dframe3 -side top -anchor center \
-expand no -padx 3
pack .dframe3 -in .dframe2 -side top -expand no -padx 14
pack .dframe2pad .dframe2 -in .dframe1 -side left -expand no -pady 11
canvas .logo -relief sunken -bd 0 -highlightthickness 0 -borderwidth 0 \
-background $LAYOUT(display_inner_frame) -width 40 -height 41
.logo create oval 9 3 28 23 -fill $LAYOUT(keypad_bg) \
-outline $LAYOUT(keypad_bg)
.logo create rectangle 16 2 21 3 -fill $LAYOUT(keypad_bg) \
-outline $LAYOUT(keypad_bg)
.logo create rectangle 16 22 21 22 -fill $LAYOUT(keypad_bg) \
-outline $LAYOUT(keypad_bg)
.logo create text 18 14 -anchor center -text IQ -font $LAYOUT(FnLogo1) \
-fill $LAYOUT(display_inner_frame)
.logo create rectangle 0 24 36 25 -fill black -outline $LAYOUT(keypad_bg)
.logo create text 19 32 -anchor center -text 15C \
-font $LAYOUT(FnLogo2) -fill $LAYOUT(keypad_bg)
.logo create rectangle 1 1 37 38 -outline $LAYOUT(keypad_bg) -width 3
pack .logo -in .dframe1 -expand no -side right -padx 10 -pady 10 -anchor n
pack .dframe1 -side top -expand yes -fill x
frame .sep1 -background $LAYOUT(keypad_bg) -height 6p -relief raised \
-borderwidth 2
pack .sep1 -side top -expand no -fill both
# Layout the keypad
frame .fkey -background $LAYOUT(keypad_bg) -relief groove
frame .fkplu -background $LAYOUT(keypad_frame) -relief flat -width 3
frame .fkpcu -background $LAYOUT(keypad_frame) -relief flat -height 3
frame .keys -background $LAYOUT(keypad_bg) -relief flat
foreach kk $HP15_KEYS {
grid [hp_key "[lindex $kk 0][lindex $kk 1]" [lindex $kk 4] [lindex $kk 5]\
[lindex $kk 6] [lindex $kk 3] [lindex $kk 7] [lindex $kk 8]\
[lindex $kk 9]]\
-in .keys -row [lindex $kk 0] -column [lindex $kk 1] \
-rowspan [lindex $kk 2] -stick ns
}
for {set ii 1} {$ii <= 10} {incr ii} {
grid configure .btn_1$ii -padx $LAYOUT(BtnPadX)
}
for {set ii 1} {$ii <= 10} {incr ii} {
grid configure .btn_2$ii -pady $LAYOUT(BtnPadY)
if {$ii != 6} {grid configure .btn_4$ii -pady $LAYOUT(BtnPadY)}
}
# Re-configure keys that differ from standard layout
# Depending on operating system, font and Tcl/Tk version the ENTER button is
# sometimes slightly to high because of its vertical label. Use small font here.
.btn_36.btn configure -font $LAYOUT(FnEnter) -wraplength 1 -height 5
.btn_41.btn configure -height 2
.btn_42.btn configure -background $LAYOUT(fbutton_bg) -foreground black \
-height 2
.btn_42.gbtn configure -background $LAYOUT(fbutton_bg) -foreground black
.btn_43.btn configure -background $LAYOUT(gbutton_bg) -foreground black \
-height 2
.btn_43.gbtn configure -background $LAYOUT(gbutton_bg) -foreground black
frame .fkpcll -background $LAYOUT(keypad_frame) -relief flat \
-width 7 -height 6
label .fkpclc -background $LAYOUT(keypad_bg) \
-text " I N T E L L I G E N C E Q U O T I E N T " \
-font $LAYOUT(FnBrand) -foreground $LAYOUT(keypad_frame)
frame .fkpclr -background $LAYOUT(keypad_frame) -relief flat
update
.fkpclr configure -width \
[expr [winfo reqwidth .keys] - [winfo reqwidth .fkpcll] - \
[winfo reqwidth .fkpclc]]
frame .fkpru -background $LAYOUT(keypad_frame) -relief flat -width 3
# Gridding
grid .fkplu -in .fkey -row 0 -column 0 -rowspan 4 -sticky ns
grid .fkpcu -in .fkey -row 0 -column 1 -columnspan 3 -sticky nsew
grid .keys -in .fkey -row 1 -column 1 -columnspan 3
grid .fkpcll -in .fkey -row 3 -column 1 -sticky nsw
grid .fkpclc -in .fkey -row 2 -column 2 -rowspan 3 -sticky w -ipadx 1
grid .fkpclr -in .fkey -row 3 -column 3 -sticky nsew
grid .fkpru -in .fkey -row 0 -column 4 -rowspan 4 -sticky ns
pack .fkey -side top -expand yes -fill both -pady 2 -padx 2
# Align display according to font settings, especially scale factor
.dframe2pad configure -width \
[expr round([winfo x .btn_11] + [winfo reqwidth .btn_11] + 12)]
# Additional keyboard and mouse bindings not done in procedure 'hp_key'.
# Distinguish between KeyPress and KeyRelease for some of the keys.
bind . <KeyPress-Right> "key_press 21 21 %T"
bind . <KeyRelease-Right> "key_release 21 21 %T"
bind .btn_21.btn <ButtonPress-1> "key_press 21 21 %T"
bind .btn_21.btn <ButtonRelease-1> "key_release 21 21 %T"
bind . <KeyPress-Left> "key_press 21 43_21 %T"
bind . <KeyRelease-Left> "key_release 21 43_21 %T"
bind .btn_21.gbtn <ButtonPress-1> "key_press 21 43_21 %T"
bind .btn_21.gbtn <ButtonRelease-1> "key_release 21 43_21 %T"
bind . <KeyPress-space> "key_press 35 42_35 %T"
bind . <KeyRelease-space> "key_release 35 42_35 %T"
bind .btn_35.fbtn <ButtonPress-1> "key_press 35 42_35 %T"
bind .btn_35.fbtn <ButtonRelease-1> "key_release 35 42_35 %T"
bind . <KeyPress-i> "key_press 24 42_24 %T"
bind . <KeyRelease-i> "key_release 24 42_24 %T"
bind .btn_24.fbtn <ButtonPress-1> "key_press 24 42_24 %T"
bind .btn_24.fbtn <ButtonRelease-1> "key_release 24 42_24 %T"
bind .btn_45.gbtn <ButtonPress-1> "key_press 45 43_45 %T"
bind .btn_45.gbtn <ButtonRelease-1> "key_release 45 43_45 %T"
# We must handle NumLock state on our own under UNIX
if {$::tcl_platform(platform) == "unix"} {
foreach {kpk kcode} {Home 7 Up 8 Prior 9 Left 4 Begin 5 Right 6 \
End 1 Down 2 Next 3 Insert 0} {
bind . <KeyPress-KP_$kpk> "kp_key_press %s $kcode"
}
bind . <KeyPress-KP_Delete> "kp_key_press %s 48"
}
# Pop-up menu bindings
bind .btn_41.btn <ButtonPress-3> "show_on_options %b"
bind .dframe1 <ButtonPress-3> "show_on_options %b"
bind . <Alt-o> "show_on_options %b"
bind . <F10> "show_on_options %b"
bind .btn_42.btn <ButtonPress-1> "set_status f \n key_event 42 42"
bind .btn_42.gbtn <ButtonPress-1> "set_status f \n key_event 42 42"
bind . <f> "key_event 42 42\n set_status f"
bind .btn_43.btn <ButtonPress-1> "set_status g \n key_event 43 43"
bind .btn_43.gbtn <ButtonPress-1> "set_status g \n key_event 43 43"
bind . <g> "key_event 43 43 \n set_status g"
bind .btn_44.btn <ButtonPress-3> "show_storage 44 %b"
bind . <Alt-m> "show_storage 44 %b"
bind .btn_45.btn <ButtonPress-3> "show_storage 45 %b"
bind . <Alt-r> "show_storage 45 %b"
bind .btn_29.gbtn <ButtonPress-3> "show_flags %b"
bind . <Alt-f> "show_flags %b"
bind .btn_310.gbtn <ButtonPress-3> "show_test_options %b"
bind . <Alt-t> "show_test_options %b"
bind .btn_22.btn <ButtonPress-3> "func_gto_chs %b"
bind .display <ButtonPress-3> "show_content %b"
bind .status <ButtonPress-3> "show_content %b"
bind . <Alt-s> "show_content %b"
# Miscellaneous HP-15C function bindings
bind . <Alt-period> "exchange_seps"
bind . <Alt-comma> "exchange_seps"
for {set ii 0} {$ii < 10} {incr ii} {
bind . <Alt-Key-$ii> "dispatch_key 32_$ii"
}
bind . <MouseWheel> "disp_scroll %D"
bind . <F11> {set HP15(mnemonics) [expr !$HP15(mnemonics)]}
bind . <Alt-F11> {set HP15(prgmcoloured) [expr !$HP15(prgmcoloured)]}
# Operating system related bindings
bind . <F1> {help simulator}
bind . <Control-F1> {help prgm}
bind . <Control-c> "clipboard_set x"
bind . <Control-v> "clipboard_get"
bind . <ButtonPress-2> "clipboard_get"
bind . <Control-m> "mem_save"
bind . <Control-l> "mem_load"
bind . <Control-o> "prgm_open"
bind . <Control-s> "prgm_save"
}
# ------------------------------------------------------------------------------
# Startup procedure
# Clear everything and reload previous session
clearall
mem_load
# Draw the GUI and define
gui_draw
trace variable stack(x) w show_x
trace variable curdisp w showLCD
trace variable FLAG(9) w disp_flash
# Update the display
show_x
set_status NIL
# Check for browser configuration
if ![string length $HP15(browser)] {
set HP15(browser) [lindex [browser_lookup] 1]
}
# ------------------------------------------------------------------------------
# Window manager configuration & communication
wm protocol . WM_DELETE_WINDOW {exit_handler}
wm title . " $APPDATA(titlewide)"
wm iconname . "IQ-15C"
wm resizable . false false
option add *Dialog.msg.font $LAYOUT(FnMenu) userDefault
# ------------------------------------------------------------------------------
# And now show the interface in all it's beauty...
update
