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 "" "dispatch_key 1$ii" bind .btn_1$ii.btn "" "key_event 1$ii 42_1$ii" } } else { for {set ii 1} {$ii < 5} {incr ii} { bind .btn_1$ii.fbtn "" "dispatch_key 42_1$ii" bind .btn_1$ii.btn "" "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 vdelete stack(x) w show_x # any key or button event will interrupt a running program grab .logo focus .logo bind .logo {prgm_interrupt} bind .logo {prgm_interrupt} set iter 0 set status(num) 1 set prgstat(running) 1 set prgstat(curline) $start while {$prgstat(running)} { if {$curdisp == ""} { set curdisp " running" } else { set curdisp "" } update after $HP15(delay) prgm_step if {[incr iter]> $prgstat(maxiter)} {set prgstat(running) 0} if {$prgstat(interrupt)} {set prgstat(running) 0} } # re-enable tracing on stack(x) and reset interrupt handling trace variable stack(x) w show_x grab release .logo focus . set status(num) 1 if {$prgstat(interrupt)} { error "" "" {INTERRUPT} } elseif {!$status(error)} { show_x } } # ------------------------------------------------------------------------------ proc func_pse {} { global HP15 status if {!$status(PRGM)} { show_x update after $HP15(pause) } } # ------------------------------------------------------------------------------ proc func_rs {} { global prgstat if {$prgstat(running)} { set prgstat(running) 0 update } else { if {$prgstat(curline) == 0} {incr prgstat(curline)} prgm_run $prgstat(curline) } } # ------------------------------------------------------------------------------ proc func_pr {} { global status FLAG set_status PRGM if {$status(PRGM)} { set FLAG(9) 0 show_curline } else { set status(num) 1 show_x } } # ------------------------------------------------------------------------------ proc func_rtn {} { global prgstat set prgstat(curline) [lindex $prgstat(rtnadr) end] if {[llength $prgstat(rtnadr)] > 1} { set prgstat(rtnadr) [lreplace $prgstat(rtnadr) end end] } } # ------------------------------------------------------------------------------ proc func_on {} { global APPDATA set answer [tk_messageBox -type okcancel -icon question -default ok \ -title $APPDATA(titlewide) \ -message "Exit Tcl/Tk $APPDATA(title) Simulator?"] if {"$answer" == "ok"} {exit_handler} } # ------------------------------------------------------------------------------ proc lookup_keyseq { keyseq by_func } { global HP15_KEY_FUNCS set rc "" set ind [lsearch {0 42 43 44 45} [string range $keyseq 0 1]] if {$ind == -1} {set ind 0} set funclist [lindex $HP15_KEY_FUNCS $ind] if {$by_func == 1} { foreach ff $funclist { if {[regexp "^[lindex $ff 0]\$" $keyseq]} { set rc $ff break } } } else { foreach ff $funclist { if {[string match "$keyseq\_*" $ff]} { set rc $ff break } } } return $rc } # ------------------------------------------------------------------------------ proc check_attributes { func num } { global status stack # Numbers with leading zeros are interpreted as octal number by the Tcl/Tk # interpreter. Must manipulate stack(x) value for most of the functions. if {!$status(num)} { if {$stack(x) != 0.0 && [lsearch {func_bs func_chs func_digit} $func] == -1} { regsub {^\-0+} $stack(x) {-} tmp regsub {^0+} $tmp {} stack(x) } } move x s if {$num} {set status(num) 1} } # ------------------------------------------------------------------------------ proc dispatch_key { kcode args } { global status FLAG isseq keyseq errorCode set fmatch "" set svar "" if {$status(error)} { set status(error) 0 if {$status(PRGM)} { show_curline } else { show_x } return } if {$keyseq != ""} { if {[string match {4[23]} $kcode] && [string match {4[23]} $keyseq]} { set keyseq $kcode } else { set_status fg_off set keyseq $keyseq\_$kcode # This will allow abbreviated key sequences regsub {_4[23]} $keyseq "" keyseq } } else { set keyseq $kcode } set fmatch [lookup_keyseq $keyseq 1] if {$fmatch != ""} { # Key sequence matches a function foreach {kseq func alstx anum aprgm} $fmatch { regexp $kseq$ $keyseq mvar svar if {$status(PRGM) && $aprgm} { prgm_addstep $keyseq } else { set keyseq "" check_attributes [lindex $func 0] $anum # This is where all func_tions are executed if {[catch { # Args are not passed through if we have a sequence. if {$isseq} { eval $func$svar } else { eval $func$svar $args } }]} {error_handler $errorCode} if {!$status(error) && $status(num) && $alstx} {move s LSTx} } } set keyseq "" if {$aprgm && $status(liftlock)} {incr status(liftlock) -1} } else { # If key sequence doesn´t match exactly check for longer one. set seq [lookup_keyseq $keyseq 0] # Sequence doesn´t match. Start new sequence with last key typed in. if {$seq == "" && $kcode != ""} { set keyseq "" set isseq 0 if {$status(f)} {set kcode 42_$kcode} if {$status(g)} {set kcode 43_$kcode} if {"$args" == ""} { dispatch_key $kcode } else { dispatch_key $kcode $args } } else { set isseq 1 } } } # ------------------------------------------------------------------------------ proc check_on_num {len name el op} { global $name ${name}_oldval if {[string compare $el {}]} { set old ${name}_oldval\($el) set name $name\($el) } else { set old ${name}_oldval } if {([string length [set $name]] > $len) || \ [regexp {^[0-9]*$} [set $name]] == 0} { set $name [set $old] } else { set $old [set $name] } } # ------------------------------------------------------------------------------ proc isInt { ii len } { # return [regexp {^[1234567890]*$} "$ii"] expr {[string is integer $ii] && [string length [string trim $ii]] <= $len} } # ------------------------------------------------------------------------------ proc browser_lookup {} { global APPDATA set bl {} foreach bw $APPDATA(browserlist) { set bwf [auto_execok $bw] if [string length $bwf] { lappend bl "$bw" "$bwf" } } return $bl } # ------------------------------------------------------------------------------ proc browser_select { wid browser } { global APPDATA set nbw [tk_getOpenFile -parent .prefs -initialdir "[file dirname $browser]" \ -title "$APPDATA(title): Select help file browser" \ -filetypes $APPDATA(exetypes)] if {[string length $nbw] > 0} { $wid configure -state normal $wid delete 0 end $wid insert 0 $nbw $wid xview end $wid configure -state disabled } } # ------------------------------------------------------------------------------ proc fontset_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 "preferences_apply true .prefs" bind .prefs "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 "destroy .about" bind .about "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 "" "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 "" "key_event $kname $kcode" foreach kk $bnd { if {[string is digit $kk]} { bind . "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 "" "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 . "key_press 21 21 %T" bind . "key_release 21 21 %T" bind .btn_21.btn "key_press 21 21 %T" bind .btn_21.btn "key_release 21 21 %T" bind . "key_press 21 43_21 %T" bind . "key_release 21 43_21 %T" bind .btn_21.gbtn "key_press 21 43_21 %T" bind .btn_21.gbtn "key_release 21 43_21 %T" # bind . "key_press 35 42_35 %T" # bind . "key_release 35 42_35 %T" bind .btn_35.fbtn "key_press 35 42_35 %T" bind .btn_35.fbtn "key_release 35 42_35 %T" bind . "key_press 24 42_24 %T" bind . "key_release 24 42_24 %T" bind .btn_24.fbtn "key_press 24 42_24 %T" bind .btn_24.fbtn "key_release 24 42_24 %T" bind .btn_45.gbtn "key_press 45 43_45 %T" bind .btn_45.gbtn "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 . "kp_key_press %s $kcode" } bind . "kp_key_press %s 48" } } # Pop-up menu bindings bind .btn_41.btn "show_on_options %b" bind .dframe1 "show_on_options %b" bind . "show_on_options %b" bind . "show_on_options %b" bind .btn_42.btn "set_status f \n key_event 42 42" bind .btn_42.gbtn "set_status f \n key_event 42 42" bind . "key_event 42 42\n set_status f" bind .btn_43.btn "set_status g \n key_event 43 43" bind .btn_43.gbtn "set_status g \n key_event 43 43" bind . "key_event 43 43 \n set_status g" bind .btn_44.btn "show_storage 44 %b" bind . "show_storage 44 %b" bind .btn_45.btn "show_storage 45 %b" bind . "show_storage 45 %b" bind .btn_29.gbtn "show_flags %b" bind . "show_flags %b" bind .btn_310.gbtn "show_test_options %b" bind . "show_test_options %b" bind .btn_22.btn "func_gto_chs %b" bind .display "show_content %b" bind .status "show_content %b" bind . "show_content %b" # Miscellaneous HP-15C function bindings bind . "exchange_seps" bind . "exchange_seps" for {set ii 0} {$ii < 10} {incr ii} { bind . "dispatch_key 32_$ii" } bind . "disp_scroll %D" bind . {set HP15(mnemonics) [expr !$HP15(mnemonics)]} bind . {set HP15(prgmcoloured) [expr !$HP15(prgmcoloured)]} # Operating system related bindings bind . {help simulator} bind . {help prgm} bind . "clipboard_set x" bind . "clipboard_get" bind . "clipboard_get" bind . "mem_save" bind . "mem_load" bind . "prgm_open" bind . "prgm_save" } # ------------------------------------------------------------------------------ # Startup procedure # Clear everything and reload previous session clearall mem_load # Draw the GUI and define key bindings gui_draw trace variable stack(x) w show_x trace variable curdisp w disp_update trace variable FLAG(9) w disp_flash # Update the display show_x set_status NIL # Check for browser configuration if ![string length $HP15(browser)] { set HP15(browser) [lindex [browser_lookup] 1] } # ------------------------------------------------------------------------------ # Window manager configuration & communication wm protocol . WM_DELETE_WINDOW {exit_handler} wm title . " $APPDATA(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 Smith]Fixed 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 [http://www.hpmuseum.org/simulate/simulate.htm]. 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. ---- !!!!!! %| [Category Application] | [Category Mathematics] |% !!!!!!