HP Calculator Simulations
HP-15C Torsten Manz
[http://www.hpmuseum.org/simulate/15_1_205.zip]
Larry Smith I see no HP-15C_Simulator_Font.ttf file in the above link.
Torsten Manz has written a GPL'd HP-15C simulation entirely in Tcl/Tk. This version requires one install the included HP-15C simulation font.
Larry Smith took Torsten's work and added a version of LCD hexa panel and removed the need to install a font. I also changed the name to IQ-15C, since Torsten's version was so faithful to the actual calculator I got nervous about trademark issues.
My website is just too unstable right now.
#!/bin/sh
#-*-tcl-*-
# the next line restarts using wish \
exec wish "$0" -- ${1+"$@"}
# -----------------------------------------------------------------------------
#
# H E W L E T T · P A C K A R D 15C
#
# A simulator written in Tcl/TK
#
# © 1997-2006 Torsten Manz
# © 2008 LCD code Larry Smith
#
# -----------------------------------------------------------------------------
#
# 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
# proc announce args { tk_messageBox -message "$args" -icon info -type ok }
# -----------------------------------------------------------------------------
# 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 10
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 disp_update { args } {
global curdisp llcd lcdshape eurostyle dwidth
# uncomment this line and comment next to switch from LCD to LED
# set colors {#000000 #ff0000 #000000 #333333 }
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
set useiq 0
array set APPDATA {
title "HEWLETT·PACKARD 15C"
titlewide "H E W L E T T · P A C K A R D 15C"
titleverywide " H E W L E T T · P A C K A R D "
titleshort " HP-15c "
Char1 h
Char1x 15
Char1y 12
Char2 p
Char2x 22
Char2y 14
version 1.2.05
copyright "COPYRIGHT \u00A9 1997-2006, Torsten Manz"
copyright2 "LCD Addition \u00A92008 by Larry Smith"
filetypes {{"HP-15C Programs" {.15c}} {"Text files" {.txt}}}
}
if $useiq {
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"
titleverywide " I N T E L L I G E N C E · Q U O T I E N T "
titleshort " IQ-15c "
Char1 h
Char1 I
Char1x 14
Char1y 12
Char2 Q
Char2x 21
Char2y 15
version 1.2.05
copyright "COPYRIGHT \u00A9 1997-2006, Torsten Manz"
copyright2 "LCD Addition \u00A92008 by Larry Smith"
filetypes {{"IQ-15C Programs" {.15c}} {"Text files" {.txt}}}
}
}
set APPDATA(SerialNo) "9931G0[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 #9E9E87
display_outer_frame #F2F5F5
display_inner_frame #D9DEDD
keypad_bg #484848
button_bg #434343
keypad_frame #E0E0E0
fbutton_bg #E1A83E
gbutton_bg #6CB7BD
BtnWidth 4
BtnPadX 1
BtnPadY 5
}
if $useiq {
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
}
}
# 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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier} 12 bold"
FnScale 1.35
}}
{ {"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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier} 12 bold"
FnScale 1.35
}}
{ {"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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 12 bold"
FnScale 1.35
}}
{ {"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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier} 10 bold"
FnScale 1.35
}}
{ {"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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier} 12 bold"
FnScale 1.35
}}
{ {"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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 12 bold"
FnScale 1.35
}}
{ {"unix" "Microsoft fonts" 81 135} {
FnDisplay "{Sans} 26"
FnStatus "{Microsoft Sans Serif} 8"
FnButton "Arial 12 bold"
FnEnter "Arial 10 bold"
FnFGBtn "Arial 9"
FnBrand "Arial 9 bold"
FnLogo1 "{Chancery} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 12 bold"
FnScale 1.35
}}
{ {"windows" "Microsoft fonts, small" 91 119} {
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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 10 bold"
FnScale 1.35
}}
{ {"windows" "Microsoft fonts" 91 119} {
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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 10 bold"
FnScale 1.35
}}
{ {"windows" "URW fonts, small" 91 119} {
FnDisplay "{Sans} 22"
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} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 10 bold"
FnScale 1.35
}}
{ {"windows" "Microsoft fonts, small" 120 140} {
FnDisplay "{Sans} 21"
FnStatus "{Microsoft Small Fonts} 6"
FnButton "Arial 9 bold"
FnEnter "Arial 8 bold"
FnFGBtn "{Microsoft Sans Serif} 6"
FnBrand "Arial 7 bold"
FnLogo1 "{Chancery} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 10 bold"
FnScale 1.69
}}
{ {"windows" "Microsoft fonts" 120 140} {
FnDisplay "{Sans} 22"
FnStatus "{Microsoft Sans Serif} 7"
FnButton "Arial 10 bold"
FnEnter "Arial 9 bold"
FnFGBtn "{Microsoft Sans Serif} 7"
FnBrand "Arial 8 bold"
FnLogo1 "{Chancery} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 10 bold"
FnScale 1.69
}}
{ {"windows" "URW fonts, small" 120 140} {
FnDisplay "{Sans} 19"
FnStatus "{Nimbus Sans L} 6"
FnButton "{Nimbus Sans L} 8 bold"
FnEnter "{Nimbus Sans L} 7 bold"
FnFGBtn "{Bitstream Vera Sans} 6"
FnBrand "{Nimbus Sans L} 6 bold"
FnLogo1 "{Chancery} 10 bold italic"
FnLogo2 "{Sans} 10"
FnMenu "{Courier New} 9 bold"
FnScale 1.69
}}
}
# 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) [expr round([tk scaling]*72) < 120 ? 8 : 11]
if {[file exists hp-15c.ico]} {
set iconFile hp-15c.ico
wm iconbitmap . $iconFile
}
}
unix {
set APPDATA(memfile) ".hp-15c.mem"
set APPDATA(exetypes) {{"All files" {*}}}
set APPDATA(browserlist) {firefox mozilla 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 4
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-plus 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} {l} }
{ 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 {
append ff "%1." $prec "e"
set var [format $ff $var]
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]
if {$status(dispmode) == "ENG" && $prec == 0} {incr len}
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}
disp_update
}
# ------------------------------------------------------------------------------
proc disp_flash { p1 p2 p3 } {
global LAYOUT HP15 FLAG
if {$FLAG(9)} {
if {[.display itemcget d0 -fill] == "black"} {
.display itemconfigure all -fill $LAYOUT(display)
.status itemconfigure all -fill $LAYOUT(display)
} else {
.display itemconfigure all -fill black
.status itemconfigure all -fill black
}
after $HP15(flash) disp_flash 1 1 1
} else {
.display itemconfigure all -fill black
.status itemconfigure all -fill black
}
}
# ------------------------------------------------------------------------------
proc mem_save {} {
global APPDATA HP15 stack istack storage prgstat PRGM FLAG
# Keep global status but set status to be saved as for shut-off!
array set status [array get ::status]
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
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 "[format "1%s000%s00 \u2192 1%s000%s00" $status(dot) $status(comma) \
$status(comma) $status(dot)]" -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) [expr $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 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
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} {
announce func_prefix: ev=$ev
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 m [expr ($stack(x) - $hours)*60.0]
set minutes [expr int([string range $m 0 [string last "." $m]])/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 m [expr ($stack(x) - $hours)*100.0]
set minutes [expr int([string range $m 0 [string last "." $m]])]
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 remove variable stack(x) write 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 add variable stack(x) write 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_list {} {
global APPDATA LAYOUT FONTSET
set rc {}
set fsn 0
set dpi [expr round([tk scaling]*72)]
foreach fs $FONTSET {
set cfs [lindex $fs 0]
if {$::tcl_platform(platform) == [lindex $cfs 0] && \
$dpi >= [lindex $cfs 2] && $dpi <= [lindex $cfs 3]} {
lappend rc [concat $fsn $cfs]
}
incr fsn
}
return $rc
}
# ------------------------------------------------------------------------------
proc fontset_apply { fsn } {
global APPDATA HP15 LAYOUT FONTSET
set found 0
set fntlst [fontset_list]
foreach fs $fntlst {
if {$fsn == [lindex $fs 0]} { set found 1 }
}
if {!$found} {
tk_messageBox -type ok -icon error -default ok -title $APPDATA(titlewide) \
-message "Error in memory file: Invalid fontset - using default set.
Check preferences for valid sets."
set fsn [lindex [lindex $fntlst 1] 0]
set HP15(fontset) $fsn
}
foreach {fs fnt} [lindex [lindex $FONTSET $fsn] 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 PREFTEXT
array set HP15tmp [array get HP15]
if [winfo exists .prefs] {
wm deiconify .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)
label $fpo.info -anchor nw -justify left \
-text "Available font sets for $::tcl_platform(os) at \
[expr round([tk scaling]*72)] dpi:"
frame $fpo.fs
foreach fs [fontset_list] {
set fsn [lindex $fs 0]
radiobutton $fpo.fs.$fsn -text "[lindex $fs 2]" -value $fsn \
-variable HP15tmp(fontset)
pack $fpo.fs.$fsn -side top -anchor w -padx 10
}
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}
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 (gold) 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 APPDATA digits
fontset_apply $HP15(fontset)
. configure -background $LAYOUT(keypad_bg)
# Calculate positions for X register display
set dwid [font measure $LAYOUT(FnDisplay) "8"]
set swid [expr int($dwid * 0.5)]
set ypos 8
set dspheight \
[expr round([font actual $LAYOUT(FnDisplay) -size]*$LAYOUT(FnScale)+$ypos)]
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 $dwid+($dwid+$swid)*$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)*$digits] \
-height [expr [font actual $LAYOUT(FnStatus) -size] * 1.5*$LAYOUT(FnScale)]
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
set logoscale [expr $LAYOUT(FnScale)/1.35]
set logosize [expr int(41*$LAYOUT(FnScale)/1.35)]
canvas .logo -relief sunken -bd 0 -highlightthickness 0 -borderwidth 0 \
-background $LAYOUT(display_inner_frame) -width $logosize \
-height [expr $logosize+1]
.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 $APPDATA(Char1x) $APPDATA(Char1y)\
-anchor center -text $APPDATA(Char1) -font $LAYOUT(FnLogo1) \
-fill $LAYOUT(display_inner_frame)
.logo create text $APPDATA(Char2x) $APPDATA(Char2y)\
-anchor center -text $APPDATA(Char2) -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
.logo scale all 0 0 $logoscale $logoscale
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 $APPDATA(titleverywide) \
-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 but not OSX
if {$::tcl_platform(platform) == "unix"} {
if {$::tcl_platform(os) == "darwin"} {
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 key bindings
gui_draw
trace add variable stack(x) write show_x
trace add variable curdisp write disp_update
trace add variable FLAG(9) write 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(titleshort) "
wm iconname . " $APPDATA(titleshort) "
wm resizable . false false
option add *Dialog.msg.font $LAYOUT(FnMenu) userDefault
# ------------------------------------------------------------------------------
# And now show the interface in all it's beauty...
wm deiconify .New version 1.2.05 available from the MoHPC (see link above) - Torsten Above code now 1.2.05. I also made the "IQ" vs "HP" thing optional - Larry Smith
I am currently very happy to use 1.2.02 but wanted to upgrade since I found a bug: launch the calculator and hit space. You get some "Internal Tcl/Tk Error: can't set "curdisp": can't read "llcd(+)": no such element in array, while executing... etc ...
Larry SmithFixed in this version. I hope. The code was reacting to a space by trying to output more than 11 character spaces of the display. When using the font, there is a flicker and then something more reasonable is displayed, but the LCD engine blew up. To fix it I removed the space dispatch binding (commented out above). Hope it doesn't break anything else.
"Link above" meant the link at the very top (sorry). A more general link is [L1 ]. The error when hitting the space bar is specific to Larry's version.
Version 1.2.08 of the original simulator should be out in a week or so. Several bug fixes and support for Windows Vista. - Torsten Larry Smith Looking forward to it.
Replace the lines at approx 4430-4436 with this:
# We must handle NumLock state on our own under UNIX but not OSX
Larry Smith Corrected above.
I am having some problems running this on OSX 10.4.11. The logic works fine but the display is very odd with some (not all) unicode characters displaying as empty boxes. I upgraded to TclTKAqua-8.4.10 but this did not fix the problem. Any suggestions? Larry Smith I think this implies that there is no version of the desired glyph in any of Tcl's font search.
DaveUssell - 2012-08-20 14:42:52
Torsten Manz has done an excellent job on the HP-15 simulation but yesterday I noticed the arctangent of 1 is not 0.79 grads/0.79 radians and 0.79 degrees. It is 50 grads/0.79 radians and 45°. There may be other errors. Please let me know if this has been corrected in an updated version. Thanks. Dave Ussell dave(at)ussell.org
dcd Did you switch to the desired angle mode before you computed the answer? It's giving me the correct answers.
Torsten - 2012.09.03
Please be aware that Larry's work is based on a very old version of the simulator. With each update I update the wiki at HP-15 Simulation.
For support requests and bug reports an e-mail to the mail address on the simulator home page is the most efficient way to communicate with me.