HP-15C Torsten Manz [http://www.hpmuseum.org/simulate/15_1_205.zip] 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. HP-15C Torsten Manz and [Larry Smith] [http://www.smith-house.org:8000/software/IQ-15C.tcl] [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-2005 Torsten Manz # extensive mods by Larry Smith 1/20/06 # # ----------------------------------------------------------------------------- # # This program is free software; you can redistribute it and/or modify it under # the terms of the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or any later version. # # This program is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. # # ------------------------------------------------------------------------------ package require Tk # ------------------------------------------------------------------------------ # Hide window until everything is ready wm withdraw . ### LCD NUMBER DISPLAY ENGINE ### package require Tk # hex segment set dx 2 set 2dx 4 set dy 2 set 2dy 4 set seglen 8 set dheight [expr 2*$seglen+4*$dy] set dwidth 25 set digits 11 set coord1 "0 0" set coord2 "$dx -$dy" set coord3 "[expr $dx+$seglen] -$dy" set coord4 "[expr $2dx+$seglen] 0" set coord5 "[expr $dx+$seglen] $dy" set coord6 "$dx $dy" set horseg "$coord1 $coord2 $coord3 $coord4 $coord5 $coord6" set coord1 "0 0" set coord2 "$dx -$dy" set coord3 "$2dx 0" set coord4 "$2dx $seglen" set coord5 "$dx [expr $seglen+$dy]" set coord6 "0 $seglen" set verseg "$coord1 $coord2 $coord3 $coord4 $coord5 $coord6" proc getseg { xoffset yoffset isHorizontal } { global horseg verseg dx dx 2dx 2dy seglen set xoffset [ expr $xoffset ] set yoffset [ expr $yoffset ] if $isHorizontal { set result $horseg } else { set result $verseg } for {set j 0 } { $j < 12 } { incr j } { set result [ lreplace $result $j $j [ expr [lindex $result $j] + $xoffset] ] incr j set result [ lreplace $result $j $j [ expr [lindex $result $j] + $yoffset] ] } return $result } # The shapes of individual elements of a digit set lcdshape(a) [ getseg 0 0 0 ] set lcdshape(b) [ getseg $dx -$dy 1 ] set lcdshape(c) [ getseg $2dx+$seglen 0 0 ] set lcdshape(d) [ getseg $2dx+$seglen $2dy+$seglen 0 ] set lcdshape(e) [ getseg $dx 3*$dy+2*$seglen 1 ] set lcdshape(f) [ getseg 0 $2dy+$seglen 0 ] set lcdshape(g) [ getseg $dx $dy+$seglen 1 ] set lcdshape(h) {18 22 18 28 23 28 23 22 } set lcdshape(i) {18 28 23 28 16 34} # Which elements are turned on for a given digit? array set llcd { 0 {a b c d e f} 1 {c d} 2 {b c e f g} 3 {b c d e g} 4 {a c d g} 5 {a b d e g} 6 {a b d e f g} 7 {b c d} 8 {a b c d e f g} 9 {a b c d e g} A {a b c d f g} B {a d e f g} C {a b e f} D {c d e f g} E {a b e f g} F {a b f g} - {g} . {h} , {h i} r {a b} u {a g c} n {a b c} i { c } g {a b c d e g} e {a b e f g} o {a b c g} { } {} } # Displays a decimal str using LCD digits in the top-left of the canvas set eurostyle 0 proc showLCD { n1 n2 op } { global curdisp llcd lcdshape eurostyle dwidth set colors {#929292 #000000 #929292 #A2A2A2} set lcdoffset 0 .display delete lcd foreach {onRim onFill offRim offFill} $colors {break} set len [ string length $curdisp ] for { set j 0 } { $j < $len } { incr j } { set glyph [ string index $curdisp $j ] set next [ string index $curdisp [ expr $j+1 ] ] foreach symbol {a b c d e f g} { if {[lsearch $llcd($glyph) $symbol] != -1} { .display move [.display create polygon $lcdshape($symbol) -tags lcd \ -outline $onRim -fill $onFill] $lcdoffset 8 } else { .display move [.display create polygon $lcdshape($symbol) -tags lcd \ -outline $offRim -fill $offFill] $lcdoffset 8 } } if { $next eq "." } { .display move [.display create polygon $lcdshape(h) -tags lcd \ -outline $onRim -fill $onFill] $lcdoffset 0 if $eurostyle { .display move [.display create polygon $lcdshape(i) -tags lcd \ -outline $onRim -fill $onFill] $lcdoffset 0 } incr j } elseif { $next eq "," } { .display move [.display create polygon $lcdshape(h) -tags lcd \ -outline $onRim -fill $onFill] $lcdoffset 0 if !$eurostyle { .display move [.display create polygon $lcdshape(i) -tags lcd \ -outline $onRim -fill $onFill] $lcdoffset 0 } incr j } incr lcdoffset $dwidth } update } # ------------------------------------------------------------------------------ # Application data: All non persistent parameters array set APPDATA { title "INTELLIGENCE QUOTIENT 15C" titlewide "I N T E L L I G E N C E Q U O T I E N T 1 5 C" version 1.2.02 copyright "COPYRIGHT \u00A9 1997-2005, Torsten Manz, et al" filetypes {{"IQ-15C Programs" {.15c}} {"Text files" {.txt}}} } set APPDATA(SerialNo) "4537G0[string map {. {}} $APPDATA(version)]" # ------------------------------------------------------------------------------ # Check on required minimum Tcl/TK version and font option add *Dialog.msg.font "Helvetica 10" userDefault option add *Dialog.msg.wrapLength 600 userDefault if {$tk_version < "8.0"} { puts $APPDATA(titlewide) puts "ERROR: This program requires Tcl/Tk 8.4 or higher." exit } elseif {$tk_version < "8.4"} { tk_messageBox -type ok -icon error -default ok -title $APPDATA(titlewide) \ -message "This program requires Tcl/Tk 8.4 or higher." exit } # ------------------------------------------------------------------------------ # Default program settings array set HP15 { breakstomenu 1 browser "" clpbrdc 0 dataregs 19 delay 100 flash 200 freebytes 0 gsbmax 7 maxval 9.999999999e99 mnemonics 1 pause 1000 prgmcoloured 1 prgmmenubreak 30 prgmname "" prgmregsfree 46 prgmregsused 0 prgmstounicode 1 saveonexit 1 strictHP15 1 totregs 65 } # Used by preferences dialogue box to hold changed values until Ok or Apply. array set hp15tmp {} # ------------------------------------------------------------------------------ # Platform independent interface settings array set LAYOUT { display #A2A699 display_outer_frame #C0C0C0 display_inner_frame #D9DEDD keypad_bg #484848 button_bg #434343 keypad_frame #E0E0E0 fbutton_bg #FFFF00 gbutton_bg #BBBBFF BtnWidth 5 BtnPadX 1 BtnPadY 5 } # display_outer_frame #F1F6F5 # Predefined, well adjusted font sets set FONTSET { { {"unix" "UNIX Standard fonts, small" 70 80} { FnDisplay "{Sans} 25" FnStatus "Helvetica 8" FnButton "Helvetica 11 bold" FnEnter "Helvetica 11 bold" FnFGBtn "Helvetica 9" FnBrand "{Bitstream Vera Sans} 8" FnLogo1 "{Chancery} 18" FnLogo2 "{Sans} 12 bold" FnMenu "{Courier} 12 bold" }} { {"unix" "UNIX Standard fonts" 70 80} { FnDisplay "{Sans} 29" FnStatus "Helvetica 9" FnButton "Helvetica 12 bold" FnEnter "Helvetica 12 bold" FnFGBtn "Helvetica 10" FnBrand "Helvetica 11 bold" FnLogo1 "{Chancery} 18" FnLogo2 "{Sans} 12 bold" FnMenu "{Courier} 12 bold" }} { {"unix" "Microsoft fonts" 70 80} { FnDisplay "{Sans} 28" FnStatus "Arial 9" FnButton "Arial 12 bold" FnEnter "Arial 11 bold" FnFGBtn "{Microsoft Sans Serif} 9" FnBrand "Tahoma 9" FnLogo1 "{Chancery} 18" FnLogo2 "{Sans} 12 bold" FnMenu "{Courier New} 12 bold" }} { {"unix" "UNIX standard fonts, small" 81 135} { FnDisplay "{Sans} 24" FnStatus "Helvetica 8" FnButton "Helvetica 10 bold" FnEnter "Helvetica 10 bold" FnFGBtn "Helvetica 8" FnBrand "Helvetica 9 bold" FnLogo1 "{Chancery} 18" FnLogo2 "{Sans} 10 bold" FnMenu "{Courier} 10 bold" }} { {"unix" "UNIX standard fonts" 81 135} { FnDisplay "{Sans} 26" FnStatus "Helvetica 9" FnButton "Helvetica 12 bold" FnEnter "Helvetica 11 bold" FnFGBtn "Helvetica 9" FnBrand "Helvetica 9" FnLogo1 "{Chancery} 18" FnLogo2 "{Sans} 10 bold" FnMenu "{Courier} 12 bold" }} { {"unix" "Microsoft fonts, small" 81 135} { FnDisplay "{Sans} 22" FnStatus "{Microsoft Sans Serif} 7" FnButton "Arial 9 bold" FnEnter "Arial 9 bold" FnFGBtn "Arial 8" FnBrand "Arial 8 bold" FnLogo1 "{Chancery} 18" FnLogo2 "{Sans} 10 bold" FnMenu "{Courier New} 12 bold" }} { {"unix" "Microsoft fonts" 81 135} { FnDisplay "{Sans} 26" FnStatus "{Microsoft Sans Serif} 8" FnButton "Arial 12 bold" FnEnter "Arial 10 bold" FnFGBtn "Arial 9 bold" FnBrand "Arial 9 bold" FnLogo1 "{Chancery} 18" FnLogo2 "{Sans} 10 bold" FnMenu "{Courier New} 12 bold" }} { {"windows" "Microsoft fonts, small" 91 135} { FnDisplay "{Sans} 22" FnStatus "{Microsoft Small Fonts} 6" FnButton "Arial 9 bold" FnEnter "Arial 8 bold" FnFGBtn "{Microsoft Sans Serif} 6" FnBrand "Arial 7 bold" FnLogo1 "{Chancery} 12" FnLogo2 "{Sans} 9 bold" FnMenu "{Courier New} 10 bold" }} { {"windows" "Microsoft fonts" 91 135} { FnDisplay "{Sans} 23" FnStatus "{Microsoft Sans Serif} 7" FnButton "Arial 10 bold" FnEnter "Arial 9 bold" FnFGBtn "{Microsoft Sans Serif} 7" FnBrand "Arial 8 bold" FnLogo1 "{Chancery} 12" FnLogo2 "{Sans} 9 bold" FnMenu "{Courier New} 10 bold" }} { {"windows" "URW fonts, small" 91 135} { FnDisplay "{Sans} 17" FnStatus "{Nimbus Sans L} 7" FnButton "{Nimbus Sans L} 9 bold" FnEnter "{Nimbus Sans L} 8 bold" FnFGBtn "{Bitstream Vera Sans} 7" FnBrand "{Nimbus Sans L} 7 bold" FnLogo1 "{Chancery} 18" FnLogo2 "{Sans} 9 bold" FnMenu "{Courier New} 10 bold" }} } # Labels for preferences. Used both in dialogue and message boxes. array set PREFTEXT { breakstomenu "Two column storage menu" browser "Help file browser" clpbrdc "Use C locale for clipboard" delay {Delay value [ms]} fonthint \ "Changes to font settings take effect when you\nrestart the Simulator." frm_browser "Help file browser" frm_fontset "Font settings" frm_os "System settings" frm_simulator "Simulator settings" mnemonics "Program mnemonics" pause {Pause length [ms]} prgmcoloured "Coloured program menu" prgmmenubreak "Lines per column in program menu" prgmstounicode "Encode programs in UNICODE" saveonexit "Save memory on exit" strictHP15 "Strict HP-15C behaviour" } # ------------------------------------------------------------------------------ # Platform specific settings switch $::tcl_platform(platform) { windows { set APPDATA(memfile) "HP-15C.mem" set APPDATA(exetypes) {{"Executable files" {.exe}}} set APPDATA(browserlist) {mozilla firefox netscape opera start iexplore hh} switch -glob "$::tcl_platform(os) $::tcl_platform(osVersion)" { "Windows 95 *" {set APPDATA(HOME) $env(windir)} "Windows NT 4.0" {set APPDATA(HOME) $env(homedrive)$env(homepath)} "Windows NT 5.*" {set APPDATA(HOME) $env(APPDATA)} -- { tk_messageBox -type ok -icon error -default ok \ -title $APPDATA(titlewide) -message \ "$::tcl_platform(os) $::tcl_platform(osVersion) is not supported." } } set HP15(prgmdir) $APPDATA(HOME) set HP15(fontset) 8 } unix { set APPDATA(memfile) ".hp-15c.mem" set APPDATA(exetypes) {{"All files" {*}}} set APPDATA(browserlist) {mozilla firefox netscape opera konqueror} set APPDATA(HOME) $env(HOME) set HP15(fontset) [expr round([tk scaling]*72) < 81 ? 1 : 4] set HP15(prgmdir) $APPDATA(HOME) } -- { tk_messageBox -type ok -icon error -default ok \ -title $APPDATA(titlewide) \ -message "Platform '$::tcl_platform(platform)' not supported." } } # ------------------------------------------------------------------------------ # Initialize processor, stack and storage registers set PI [expr acos(0)*2.0] array set status { f 0 g 0 user 0 BEGIN 0 RAD {} DMY 0 PRGM 0 integrate 0 solve 0 num 1 liftlock 1 dispmode FIX dispprec 3 comma , dot . error 0 seed 0 } # Must do this outside of "array set" to become evaluated set status(RADfactor) [expr $PI/180.0] # During execution two additional registers are added to the stack: # s: general scratchpad register that stores the last operand # u: used by helper functions in complex mode array set stack { x 0.0 y 0.0 z 0.0 t 0.0 LSTx 0.0 } array set istack { x 0.0 y 0.0 z 0.0 t 0.0 LSTx 0.0 } array set prgstat { curline 0 running 0 interrupt 0 rtnadr {0} maxiter {10000} } set PRGM {""} # Flags array set FLAG { 0 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 0 9 0 } # Test menu labels. Also used for mnemonics. set TEST { "x \u2260 0" "x > 0" "x < 0" "x \u2265 0" "x \u2264 0" "x = y" \ "x \u2260 y" "x > y" "x < y" "x \u2265 y" "x \u2264 y" "x = 0" } # ------------------------------------------------------------------------------ # Global program control variables set curdisp 0 set keyseq "" set isseq 0 # ------------------------------------------------------------------------------ # List of HP-15C keys # Key definitions # Each key definition consists of 10 elements: # row column : Row [1-4] and column [1-10] on the key pad # rowspan : Numbers of rows a key spans (normally 1 but 2 for ENTER) # key-code : Normally row+column, but numeric keys return number # f-label label g-label : The keys labels. Encoded in UNICODE. # f-binding binding g-binding : List of X11-keysyms bound to a key # set HP15_KEYS { { 1 1 1 11 A \u221ax x\u00B2 {Alt-a} {q} {Alt-x} } { 1 2 1 12 B e\u2191x LN {Alt-b} {e} {Alt-n} } { 1 3 1 13 C 10\u2191x LOG {Alt-c} {x} {Alt-g} } { 1 4 1 14 D y\u2191x % {Alt-d} {y} {percent} } { 1 5 1 15 E 1/x \u0394% {Alt-e} {Alt-slash backslash ssharp} {d} } { 1 6 1 16 MATRIX CHS ABS {} {Alt-minus} {bar brokenbar} } { 1 7 1 7 FIX 7 DEG {} {7 KP_7} {} } { 1 8 1 8 SCI 8 RAD {} {8 KP_8} {} } { 1 9 1 9 ENG 9 GRD {} {9 KP_9} {} } { 1 10 1 10 SOLVE \u00F7 x\u2264y {} {slash KP_Divide} {} } { 2 1 1 21 LBL SST BST {F8} {} {} } { 2 2 1 22 HYP GTO HYP\u002D\u00B9 {h} {F2} {Alt-h} } { 2 3 1 23 DIM SIN SIN\u002D\u00B9 {} {s} {} } { 2 4 1 24 (i) COS COS\u002D\u00B9 {} {c} {} } { 2 5 1 25 I TAN TAN\u002D\u00B9 {I j} {t} {} } { 2 6 1 26 RESULT EEX \u03C0 {} {E} {p} } { 2 7 1 4 x\u2194? 4 SF {Alt-less Alt-greater} {4 KP_4} {} } { 2 8 1 5 DSE 5 CF {} {5 KP_5} {} } { 2 9 1 6 ISG 6 F? {} {6 KP_6} {} } { 2 10 1 20 \u222Bxy \u00D7 x=0 {} {asterisk KP_Multiply} {} } { 3 1 1 31 PSE R/S P/R {F6} {F5} {F9} } { 3 2 1 32 \u2211 GSB RTN {} {F3} {F4} } { 3 3 1 33 PRGM R\u2193 R\u2191 {} {Down} {Up} } { 3 4 1 34 REG x\u2194y RND {} {less greater} {} } { 3 5 1 35 PREFIX \u2190 CLx {} {BackSpace} {Escape} } { 3 6 2 36 "RAN #" ENTER LSTx {numbersign} {Return KP_Enter} {} } { 3 7 1 1 \u2192R 1 \u2192P {} {1 KP_1} {} } { 3 8 1 2 \u2192H.MS 2 \u2192H {} {2 KP_2} {} } { 3 9 1 3 \u2192RAD 3 \u2192DEG {} {3 KP_3} {} } { 3 10 1 30 Re\u2194Im - TEST {Tab} {minus KP_Subtract} {} } { 4 1 1 41 "" ON "" {} {} {} } { 4 2 1 42 "" f "" {} {} {} } { 4 3 1 43 "" g "" {} {} {} } { 4 4 1 44 FRAC STO INT {} m {} } { 4 5 1 45 USER RCL MEM {u} r {} } { 4 7 1 0 x! 0 x {exclam} {0 KP_0} {} } { 4 8 1 48 \u0177,r . s {} {comma period KP_Decimal} {} } { 4 9 1 49 L.R. \u2211+ \u2211- {} {Insert} {Delete} } { 4 10 1 40 Py,x + Cy,x {} {plus KP_Add} {} } } # HP-15C Key sequence, corresponding functions and function attributes # Key sequence: A regular expression describing a set of key sequences # Function name: The Tcl function. # Attributes (0|1): # LSTx: Operand is saved in the LSTx register. # End input: Function terminates input. Thus we have a number. # Programmable: Function is programmable. set HP15_KEY_FUNCS { { { 0 "func_digit 0" 0 0 1} { 1 "func_digit 1" 0 0 1} { 2 "func_digit 2" 0 0 1} { 3 "func_digit 3" 0 0 1} { 4 "func_digit 4" 0 0 1} { 5 "func_digit 5" 0 0 1} { 6 "func_digit 6" 0 0 1} { 7 "func_digit 7" 0 0 1} { 8 "func_digit 8" 0 0 1} { 9 "func_digit 9" 0 0 1} {10 "func_div" 1 1 1} {11 "func_sqrt" 1 1 1} {12 "func_exp" 1 1 1} {13 "func_10powx" 1 1 1} {14 "func_ypowx" 1 1 1} {15 "func_inv" 1 1 1} {16 "func_chs" 0 0 1} {20 "func_mult" 1 1 1} {21 "func_sst" 0 0 0} {22_([0-9]) "func_gto " 0 1 1} {22_1([1-5]) "func_gto -" 0 1 1} {22_25 "func_gto I" 0 1 1} {22_48_([0-9]) "func_gto 1" 0 1 1} {22_16_([0-9]) "func_gto_chs " 0 0 0} {23 "func_trign sin" 1 1 1} {24 "func_trign cos" 1 1 1} {25 "func_trign tan" 1 1 1} {26 "func_digit e+0" 0 0 1} {30 "func_minus" 1 1 1} {31 "func_rs" 0 1 1} {32_([0-9]) "func_gsb " 0 1 1} {32_1([1-5]) "func_gsb -" 0 1 1} {32_25 "func_gsb I" 0 1 1} {32_48_([0-9]) "func_gsb 1" 0 1 1} {33 "func_roll 1" 0 1 1} {34 "func_xy" 0 1 1} {35 "func_bs" 0 0 0} {36 "func_enter" 0 1 1} {40 "func_plus" 1 1 1} {41 "func_on" 0 0 0} {48 "func_digit ." 0 0 1} {49 "func_sum_plus" 1 1 1} } { {42_0 "func_faculty" 1 1 1} {42_1 "func_rectangular" 1 1 1} {42_1([1-5]) "dispatch_key 32_1" 0 0 0} {42_10_([0-9]) "func_solve " 0 1 1} {42_10_1([1-5]) "func_solve -" 0 1 1} {42_10_48_([0-9]) "func_solve 1" 0 1 1} {42_16 "# not implemented" 0 0 0} {42_2 "func_hms" 1 1 1} {42_20_([0-9]) "func_integrate " 0 0 1} {42_20_1([1-5]) "func_integrate -" 0 0 1} {42_20_48_([0-9]) "func_integrate 1" 0 0 1} {42_21_([0-9]) "func_label " 0 1 1} {42_21_1([1-5]) "func_label " 0 1 1} {42_21_48_([0-9]) "func_label 1" 0 1 1} {42_22_23 "func_hyp sin" 1 1 1} {42_22_24 "func_hyp cos" 1 1 1} {42_22_25 "func_hyp tan" 1 1 1} {42_23_1([1-5]) "# not implemented" 0 0 0} {42_23_24 "func_dim_mem" 0 1 1} {42_24 "func_i" 0 1 0} {42_25 "func_I" 0 1 1} {42_26 "# not implemented" 0 0 0} {42_3 "func_rad" 1 1 1} {42_30 "func_re_im" 0 1 1} {42_31 "func_pse" 0 1 1} {42_32 "func_clearsumregs" 0 1 1} {42_33 "func_clearprgm" 0 1 0} {42_34 "func_clearreg" 0 1 1} {42_35 "func_prefix" 0 1 0} {42_36 "func_random" 0 1 1} {42_4_([0-9]) "func_xexchg " 0 1 1} {42_4_24 "func_xexchg (i)" 0 1 1} {42_4_25 "func_xexchg I" 0 1 1} {42_4_48_([0-9]) "func_xexchg 1" 0 1 1} {42_40 "func_Pyx" 1 1 1} {42_44 "func_frac" 1 1 1} {42_45 "set_status user" 0 1 0} {42_48 "func_linexpolation" 0 1 1} {42_49 "func_linreg" 0 1 1} {42_5_([0-9]) "func_dse " 0 1 1} {42_5_24 "func_dse (i)" 0 1 1} {42_5_25 "func_dse I" 0 1 1} {42_5_48_([0-9]) "func_dse 1" 0 1 1} {42_6_([0-9]) "func_isg " 0 1 1} {42_6_24 "func_isg (i)" 0 1 1} {42_6_25 "func_isg I" 0 1 1} {42_6_48_([0-9]) "func_isg 1" 0 1 1} {42_7_([0-9]) "func_dsp_mode FIX " 0 1 1} {42_7_25 "func_dsp_mode FIX I" 0 1 1} {42_8_([0-9]) "func_dsp_mode SCI " 0 1 1} {42_8_25 "func_dsp_mode SCI I" 0 1 1} {42_9_([0-9]) "func_dsp_mode ENG " 0 1 1} {42_9_25 "func_dsp_mode ENG I" 0 1 1} } { {43_0 "func_avg" 0 1 1} {43_1 "func_polar" 1 1 1} {43_10 "func_test 10" 0 1 1} {43_11 "func_xpow2" 1 1 1} {43_12 "func_ln" 1 1 1} {43_13 "func_log10" 1 1 1} {43_14 "func_percent" 1 1 1} {43_15 "func_dpercent" 1 1 1} {43_16 "func_abs" 1 1 1} {43_2 "func_h" 1 1 1} {43_20 "func_test 11" 0 1 1} {43_21 "func_bst" 0 0 0} {43_22_23 "func_ahyp sin" 1 1 1} {43_22_24 "func_ahyp cos" 1 1 1} {43_22_25 "func_ahyp tan" 1 1 1} {43_23 "func_atrign sin" 1 1 1} {43_24 "func_atrign cos" 1 1 1} {43_25 "func_atrign tan" 1 1 1} {43_26 "func_pi" 0 1 1} {43_3 "func_deg" 1 1 1} {43_30_([0-9]) "func_test " 0 1 1} {43_31 "func_pr" 0 0 0} {43_32 "func_rtn" 0 1 1} {43_33 "func_roll 3" 0 1 1} {43_34 "func_rnd" 1 1 1} {43_35 "func_clx" 0 1 1} {43_36 "func_lastx" 0 1 1} {43_4_([0-9]) "func_sf " 0 1 1} {43_4_25 "func_sf I" 0 1 1} {43_40 "func_Cyx" 1 1 1} {43_44 "func_int" 1 1 1} {43_45 "func_mem" 0 1 0} {43_48 "func_stddev" 0 1 1} {43_49 "func_sum_minus" 1 1 1} {43_5_([0-9]) "func_cf " 0 1 1} {43_5_25 "func_cf I" 0 1 1} {43_6_([0-9]) "func_Finq " 0 1 1} {43_6_25 "func_Finq I" 0 1 1} {43_7 "set_status DEG" 0 1 1} {43_8 "set_status RAD" 0 1 1} {43_9 "set_status GRAD" 0 1 1} } { {44_([0-9]) "func_sto " 0 1 1} {44_25 "func_sto I" 0 1 1} {44_24 "func_sto (i)" 0 1 1} {44_48_([0-9]) "func_sto 1" 0 1 1} {44_10_([0-9]) "func_sto_oper / " 0 1 1} {44_10_24 "func_sto_oper / (i)" 0 1 1} {44_10_25 "func_sto_oper / I" 0 1 1} {44_10_48_([0-9]) "func_sto_oper / 1" 0 1 1} {44_20_([0-9]) "func_sto_oper * " 0 1 1} {44_20_24 "func_sto_oper * (i)" 0 1 1} {44_20_25 "func_sto_oper * I" 0 1 1} {44_20_48_([0-9]) "func_sto_oper * 1" 0 1 1} {44_30_([0-9]) "func_sto_oper - " 0 1 1} {44_30_24 "func_sto_oper - (i)" 0 1 1} {44_30_25 "func_sto_oper - I" 0 1 1} {44_30_48_([0-9]) "func_sto_oper - 1" 0 1 1} {44_*36 "func_storandom" 0 1 1} {44_40_([0-9]) "func_sto_oper + " 0 1 1} {44_40_24 "func_sto_oper + (i)" 0 1 1} {44_40_25 "func_sto_oper + I" 0 1 1} {44_40_48_([0-9]) "func_sto_oper + 1" 0 1 1} } { {45_([0-9]) "func_rcl " 0 1 1} {45_25 "func_rcl I" 0 1 1} {45_24 "func_rcl (i)" 0 1 1} {45_48_([0-9]) "func_rcl 1" 0 1 1} {45_10_([0-9]) "func_rcl_oper / " 0 1 1} {45_10_24 "func_rcl_oper / (i)" 0 1 1} {45_10_25 "func_rcl_oper / I" 0 1 1} {45_10_48_([0-9]) "func_rcl_oper / 1" 0 1 1} {45_20_([0-9]) "func_rcl_oper * " 0 1 1} {45_20_24 "func_rcl_oper * (i)" 0 1 1} {45_20_25 "func_rcl_oper * I" 0 1 1} {45_20_48_([0-9]) "func_rcl_oper * 1" 0 1 1} {45_30_([0-9]) "func_rcl_oper - " 0 1 1} {45_30_24 "func_rcl_oper - (i)" 0 1 1} {45_30_25 "func_rcl_oper - I" 0 1 1} {45_30_48_([0-9]) "func_rcl_oper - 1" 0 1 1} {45_36 "func_rclrandom" 0 1 1} {45_40_([0-9]) "func_rcl_oper + " 0 1 1} {45_40_24 "func_rcl_oper + (i)" 0 1 1} {45_40_25 "func_rcl_oper + I" 0 1 1} {45_40_48_([0-9]) "func_rcl_oper + 1" 0 1 1} {45_49 "func_rclsum" 0 1 1} } } # ------------------------ End of variable definitions ------------------------- # ------------------------------------------------------------------------------ proc commify { num {sign ,} } { if {$sign == "."} {regsub {[.]} $num "," num} set trg "\\1$sign\\2\\3" while {[regsub {^([-+ ]?[0-9]+)([0-9][0-9][0-9])([- ][0-9][0-9])?} \ $num $trg num]} {} return $num } # ------------------------------------------------------------------------------ proc format_exponent { expo } { if {$expo != ""} { regsub {^([-+ ]?)0([1-9][0-9]?)} $expo {\1\2} expo set expo [expr $expo >= 0 ? \" \" : \"-\"][format "%02d" [expr abs($expo)]] } return $expo } # ------------------------------------------------------------------------------ proc format_number { var } { global HP15 status set prec $status(dispprec) set eexprecmax 6 set eex 1 # calculate mantissa and exponent parameters set log [expr $var != 0 ? int(floor(log10(abs($var)))) : 0] switch $status(dispmode) { FIX { if {$log >= -$prec && $log <= 9} { set eex 0 if {$log+$prec > 9} {set prec [expr 9-$log]} } } SCI { # Nothing to do here } ENG { set log [expr int($log/3)*3] } } # format mantissa append fmt "% ." $prec "f" if {[expr $var >= $HP15(maxval)]} { set mantissa " [string range $HP15(maxval) 0 7]" } elseif {[expr $var <= -$HP15(maxval)]} { set mantissa "-[string range $HP15(maxval) 0 7]" } elseif {$eex == 1} { set mantissa [format $fmt [expr $var/pow(10, $log)]] if {$status(dispmode) != "ENG" && $mantissa >= 10.0 && $log < 99} { incr log set mantissa [format $fmt [expr $var/pow(10, $log)]] } set len [expr ($prec > $eexprecmax ? $eexprecmax : $prec)+2] set mantissa [string range $mantissa 0 $len] } else { set mantissa [format $fmt $var] } if {[string first "." $mantissa] <= 0} {set mantissa "$mantissa."} # format exponent if {$eex == 0} { set expo "" } else { set expo [format_exponent $log] } set filler [string repeat " " [expr 12-[string length "$mantissa$expo"]]] # return concatenated number return [commify "$mantissa$filler$expo" $status(dot)] } # ------------------------------------------------------------------------------ proc format_input { var } { global status regsub {(e[+-]$)} $var {\10} var regexp {^([-+ ]?[.0-9]+)e?([+-][0-9]+)?} $var all mantissa expo if {[string index $mantissa 0] != "-"} {set mantissa " $mantissa"} set expo [format_exponent $expo] set filler [string repeat " " \ [expr 11-[string length [string map {. ""} "$mantissa$expo"]]]] return [commify [format "%s%s%s" $mantissa $filler $expo] $status(dot)] } # ------------------------------------------------------------------------------ proc format_prgm { lnum wid } { global status PRGM set kl [split [lindex $PRGM $lnum] "_"] switch [llength $kl] { 1 - 2 { set st [join $kl] } 3 { if {[lindex $kl 1] == 48} { set st [format " %2d $status(comma)%1d" [lindex $kl 0] [lindex $kl 2]] } else { set st [format "%2d$status(dot)%2d$status(dot)%2d" \ [lindex $kl 0] [lindex $kl 1] [lindex $kl 2]] } } 4 { set st [format "%2d$status(dot)%2d$status(dot) %2s" \ [lindex $kl 0] [lindex $kl 1] "$status(comma)[lindex $kl 3]"] } default { set st "" } } return "[format "%03d-%$wid\s" $lnum $st]" } # ------------------------------------------------------------------------------ proc error_handler { errinfo } { global APPDATA HP15 FLAG stack istack status prgstat curdisp errorInfo errorCode set errnum -1 set status(num) 1 if {[lindex $errinfo 0] == "ARITH"} { switch [lindex $errinfo 1] { IOVERFLOW - OVERFLOW { set stack(x) $HP15(maxval) set istack(x) $HP15(maxval) set FLAG(9) 1 show_x } NOVERFLOW { set stack(x) -$HP15(maxval) set istack(x) -$HP15(maxval) set FLAG(9) 1 show_x } UNDERFLOW { set stack(x) 0.0 show_x } INVALID - default { set errnum 0 } } } else { switch [lindex $errinfo 0] { SUM { set errnum 2 } INDEX { set errnum 3 } ADDRESS { set errnum 4 } RTN { set errnum 5 } FLAG { set errnum 6 } RECURSION { set status(solve) 0 set status(integrate) 0 set errnum 7 } SOLVE { set errnum 8 } DIM { set errnum 10 } INTERRUPT { set prgstat(running) 0 set prgstat(interrupt) 0 show_x } FILEIO { switch [lindex $errinfo 1] { ECREATE { set errmsg "Could not write file" } ENOENT { set errmsg "No such file" } EOPEN { set errmsg "Could not open file" } NONE - EFMT { set errmsg "Error parsing line [lindex $errinfo 3]" } INVCMD { set errmsg "Invalid command in line [lindex $errinfo 3]" } default { set errmsg "$errorInfo" } } set errnum 98 tk_messageBox -type ok -icon error -default ok \ -title $APPDATA(titlewide) -message "$errmsg: [lindex $errinfo 2]" } default { set errnum 99 tk_messageBox -type ok -icon error -default ok \ -title $APPDATA(titlewide) \ -message "Internal Tcl/Tk Error:\n$errorInfo" set stack(x) 0.0 } } } if {$errnum >= 0} { set status(error) 1 set prgstat(running) 0 set curdisp " error [format "%2d" $errnum]" } } # ------------------------------------------------------------------------------ proc show_x { args } { global HP15 status stack curdisp if {[catch { if {abs($stack(x)) > 0.0 && abs($stack(x)) < 1E-99} { error_handler {ARITH UNDERFLOW} } elseif {[expr $stack(x) > $HP15(maxval)]} { error_handler {ARITH OVERFLOW} } elseif {[expr $stack(x) < -$HP15(maxval)]} { error_handler {ARITH NOVERFLOW} } else { if {$status(num)} { set curdisp [format_number $stack(x)] } else { set curdisp [format_input $stack(x)] } } } errorCode]} {error_handler $errorCode} } set oldLCD "" proc disp_flash { p1 p2 p3 } { global curdisp oldLCD HP15 FLAG set save $curdisp if { $oldLCD == "" } { set oldLCD $curdisp set curdisp " " update } else { set curdisp $oldLCD set oldLCD "" if !$FLAG(9) { after $HP15(flash) disp_flash 1 1 1 } } } # ------------------------------------------------------------------------------ proc mem_save {} { global APPDATA HP15 status stack istack storage prgstat PRGM FLAG set sepline "# [string repeat - 78]" set fid [open "$APPDATA(HOME)/$APPDATA(memfile)" {RDWR CREAT TRUNC}] puts $fid $sepline puts $fid "# Tcl/Tk $APPDATA(title) memory file" puts $fid "# The Simulator is $APPDATA(copyright)" puts $fid "# Version $APPDATA(version)" puts $fid "# Memory saved on [clock format [clock seconds] -format "%c"]" puts $fid $sepline puts $fid "" foreach aa {HP15 status stack istack storage FLAG prgstat} { puts $fid $sepline puts $fid "# $aa" puts $fid "array set $aa {" foreach ii [lsort -dictionary [array names $aa]] { puts $fid " $ii {[set ${aa}($ii)]}" } puts $fid "}\n" } puts $fid $sepline puts $fid "# Program" puts $fid "set PRGM {" foreach ii $PRGM { puts $fid " {$ii}" } puts $fid "}" puts $fid $sepline close $fid } # ------------------------------------------------------------------------------ proc mem_load {} { global APPDATA HP15 status stack istack storage prgstat PRGM FLAG set fnam "$APPDATA(HOME)/$APPDATA(memfile)" if {[file exists $fnam]} { if {[catch {source $fnam} err]} { error_handler [list FILEIO EFMT $fnam $err] } } # Refresh status line set_status NIL } # ------------------------------------------------------------------------------ proc prgm_save {} { global APPDATA HP15 PRGM set sepline "# [string repeat - 44]" set fnam [tk_getSaveFile -title "$APPDATA(title): Save program" \ -defaultextension ".15C" -filetypes $APPDATA(filetypes) \ -initialdir "$HP15(prgmdir)" -initialfile "$HP15(prgmname)"] if {$fnam != ""} { if {[catch {set fid [open $fnam {RDWR CREAT TRUNC}]}]} { error_handler [list FILEIO ECREATE $fnam] close $fid return } if {$HP15(prgmstounicode)} { puts -nonewline $fid "\377\376" fconfigure $fid -encoding unicode } puts $fid $sepline puts $fid "# Tcl/Tk $APPDATA(title) Simulator program" puts $fid "# Created with version $APPDATA(version)" puts $fid "$sepline\n" for {set ii 0} {$ii < [llength $PRGM]} {incr ii} { set seq "" foreach cc [split [lindex $PRGM $ii] "_"] { append seq [format {%3d} $cc] } puts $fid "[format " %03d {%12s } %s" $ii $seq \ [build_mnemonic [lindex $PRGM $ii] 0]]" } puts $fid "\n$sepline" close $fid set HP15(prgmdir) [file dirname $fnam] set HP15(prgmname) [file tail $fnam] } } # ------------------------------------------------------------------------------ proc prgm_open {} { global APPDATA HP15 status prgstat PRGM errorCode set fnam [tk_getOpenFile -initialdir "$HP15(prgmdir)" \ -title "$APPDATA(title): Open program" -defaultextension ".15C" \ -filetypes $APPDATA(filetypes)] if {$fnam != ""} { if {[catch {set fid [open "$fnam" {RDONLY}]}]} { error_handler [list FILEIO EOPEN $fnam] close $fid return } # Check whether file is UNICODE or ASCII encoded set unic [read $fid 2] if {[string compare $unic "\377\376"] == 0 || \ [string index $unic 1] == "\000"} { fconfigure $fid -encoding unicode } if {"$unic" != "\377\376"} {seek $fid 0} set lcnt 0 set PRGMtmp {} if {[catch { while {[gets $fid curline] >= 0} { incr lcnt set curline [string trim $curline] if {[string length $curline] > 0 && [string index $curline 0] != "#"} { if {[regexp "\{(.*)\}" $curline all step] == 0} { error "" "" {EFMT} } set step [string map {" " _ " " _} [string trim $step]] if {[lookup_keyseq $step 1] == "" && [llength $PRGMtmp] > 0} { error "" "" {INVCMD} } lappend PRGMtmp $step unset step } } }]} { error_handler [list FILEIO $::errorCode $fnam $lcnt] return } close $fid # Insert empty step 000 if first step is not empty if {[lindex $PRGMtmp 0] != ""} {set PRGMtmp [linsert $PRGMtmp 0 ""]} set prgstat(curline) 0 set prgstat(rtnadr) {0} set PRGM $PRGMtmp if {$status(PRGM)} {show_curline} set HP15(prgmdir) [file dirname $fnam] set HP15(prgmname) [file tail $fnam] } } # ------------------------------------------------------------------------------ proc clipboard_set { reg } { global HP15 status stack if {[string compare $::tcl_platform(platform) "unix"]} { clipboard clear if {$HP15(clpbrdc)} { clipboard append $stack($reg) } else { clipboard append [string map ". $status(comma)" $stack($reg)] } } else { selection handle -selection PRIMARY . clipboard_transfer selection own -selection PRIMARY . } } # ------------------------------------------------------------------------------ proc clipboard_transfer { offset maxchars } { global HP15 status stack if {$HP15(clpbrdc)} { return $stack(x) } else { return [string map ". $status(comma)" $stack(x)] } } # ---------------------------------------------------------------------------- proc clipboard_get {} { global HP15 status stack # On Windows only CLIPBOARD selection exists. On UNIX most applications use # PRIMARY selection, some use CLIPBOARD (or both). We will check for both... if {[catch {set clpbrd [selection get -selection PRIMARY]}]} { catch {set clpbrd [selection get -selection CLIPBOARD]} } if {[info exists clpbrd]} { if {$HP15(clpbrdc)} { set clpbrd [string map {, ""} $clpbrd] } else { set clpbrd [string map {. "" , .} $clpbrd] } if {[string is double $clpbrd]} { if {$status(num)} {lift} set status(num) 1 set stack(x) $clpbrd } } } # ------------------------------------------------------------------------------ proc exchange_seps {} { global status set tmp $status(comma) set status(comma) $status(dot) set status(dot) $tmp if {$status(PRGM)} { show_curline } else { show_x } } # ------------------------------------------------------------------------------ proc help { topic } { global APPDATA HP15 argv0 errorInfo switch $topic { simulator { # Differentiate between running from a starpack or from wish if {[info exists starkit::topdir]} { set helpdir [file dirname $starkit::topdir] } else { set helpdir [file dirname $argv0] } if {[string compare $helpdir "."] == 0} {set helpdir [pwd]} set helpfile "$helpdir/doc/index.htm" } prgm { set helpfile "$HP15(prgmdir)/[file rootname $HP15(prgmname)].htm" } } catch {set helpfile [file nativename [lindex [glob "$helpfile*"] 0]]} if {[string length $HP15(browser)] == 0} { set msg "No help file browser configured.\nSee Preferences dialogue box." preferences } elseif {$topic == "prgm" && $HP15(prgmname) == ""} { set msg "No help file available or\nno name given for current program." } elseif {![file exists $helpfile]} { set msg "Help file not found:\n$helpfile" } if {[info exists msg]} { tk_messageBox -type ok -icon error -default ok \ -title $APPDATA(titlewide) -message $msg if [winfo exists .prefs] {focus .prefs} } else { if {[catch {eval exec $HP15(browser) [list $helpfile] &} exerr]} { tk_messageBox -type ok -icon error -default ok \ -title $APPDATA(titlewide) \ -message "Could not display help file:\n$exerr" } } } # ------------------------------------------------------------------------------ proc show_on_options { trigger } { global LAYOUT status if {[winfo exists .onm]} {destroy .onm} menu .onm -tearoff 0 -title "Options" -font $LAYOUT(FnMenu) .onm add command -label "Open program\u2026" -underline 0 \ -command "prgm_open" .onm add command -label "Save program\u2026" -underline 0 \ -command "prgm_save" .onm add separator .onm add command -label "Save memory" -underline 5 -command "mem_save" .onm add command -label "Load memory" -underline 0 -command "mem_load" if {$status(PRGM)} { set st disabled } else { set st normal } .onm add command -label "Clear all" -underline 0 -command "clearall" \ -state $st .onm add separator .onm add command \ -label "Radix: (.) or (,)" -underline 0 -command "exchange_seps" .onm add command -label "Preferences\u2026" -underline 0 \ -command "preferences" .onm add separator .onm add command -label "Help\u2026" -underline 0 -command "help simulator" .onm add command -label "About\u2026" -underline 0 -command "about" .onm add separator .onm add command -label "Exit" -underline 1 -command "exit_handler" if {$trigger == 3} { tk_popup .onm [winfo pointerx .] [winfo pointery .] } else { tk_popup .onm [winfo rootx .btn_41.btn] \ [expr [winfo rooty .btn_41.btn]+[winfo height .btn_41.btn]] } } # ------------------------------------------------------------------------------ proc show_storage { function trigger } { global LAYOUT HP15 storage if {[winfo exists .storage]} {destroy .storage} menu .storage -tearoff 0 -title "Storage" -font $LAYOUT(FnMenu) set regmax [expr $HP15(dataregs) < 19 ? $HP15(dataregs) : 19] for {set ii 0} {$ii <= $regmax} {incr ii} { .storage add command \ -label "R[format "%2d" $ii]: [format_number $storage($ii)]" if {$ii < 10} { .storage entryconfigure $ii -underline 2 \ -command "dispatch_key $function\_$ii" } else { .storage entryconfigure 10 -columnbreak $HP15(breakstomenu) .storage entryconfigure $ii \ -command "dispatch_key $function\_48_[expr $ii-10]" } } .storage add command .storage entryconfigure $ii -label "RI : [format_number $storage(I)]" \ -underline 1 -command "dispatch_key $function\_25" if {$trigger == 3} { tk_popup .storage [winfo pointerx .] [winfo pointery .] } else { tk_popup .storage [winfo rootx .btn_$function.gbtn] \ [winfo rooty .btn_$function.gbtn] } } # ------------------------------------------------------------------------------ proc show_content { trigger } { global status if {$status(error)} { show_error $trigger } elseif {$status(PRGM)} { show_prgm $trigger } else { show_stack $trigger } } # ------------------------------------------------------------------------------ proc show_stack { trigger } { global FLAG LAYOUT stack istack if {[winfo exists .stack]} {destroy .stack} menu .stack -tearoff 0 -title "Stack" -font $LAYOUT(FnMenu) set sts 3 foreach ii {t z y x} { if {$FLAG(8)} { .stack add command -command "func_roll $sts" -hidemargin 1 -label \ [format {%5s: %-15s %5s: %-15s} $ii [format_number $stack($ii)] \ i$ii [format_number $istack($ii)]] } else { .stack add command -command "func_roll $sts" -hidemargin 1 -label \ [format {%5s: %-15s} $ii [format_number $stack($ii)]] } incr sts -1 } .stack add separator if {$FLAG(8)} { .stack add command -command "dispatch_key 43_36" -hidemargin 1 -label \ [format { LSTx: %-15s iLSTX: %-15s} [format_number $stack(LSTx)] \ [format_number $istack(LSTx)]] } else { .stack add command -label " LSTx: [format_number $stack(LSTx)]" \ -command "dispatch_key 43_36" -hidemargin 1 } if {$trigger == 3} { tk_popup .stack [winfo pointerx .] [winfo pointery .] } else { tk_popup .stack [winfo rootx .status] \ [expr [winfo rooty .status] + [winfo height .status]] } } # ------------------------------------------------------------------------------ proc show_error { trigger } { global LAYOUT stack if {![winfo exists .error]} { menu .error -tearoff 0 -title "Error" -font $LAYOUT(FnMenu) .error add command -label " 0 : y \u00F7 0, LN 0, \u2026" -state disabled .error add command -label " 1 : LN A, SIN A, \u2026" -state disabled .error add command -label " 2 : \u2211 Error" -state disabled .error add command -label " 3 : R?, Aij?" -state disabled .error add command -label " 4 : LBL?, GTO > MEM, PRGM > MEM" -state disabled .error add command -label " 5 : > 7 RTN" -state disabled .error add command -label " 6 : SF > 9, CF > 9, F? > 9" -state disabled .error add command -label " 7 : SOLVE(SOLVE), \u222Bxy(\u222Bxy)" \ -state disabled .error add command -label " 8 : SOLVE ?" -state disabled .error add command -label " 9 : ON / \u00D7" -state disabled .error add command -label "10 : DIM > MEM" -state disabled .error add command -label "11 : DIM A \u2260 DIM B" -state disabled .error add separator .error add command -label "98 : File I/O error" -state disabled .error add command -label "99 : Tcl/Tk error" -state disabled .error configure -disabledforeground [.error cget -foreground] } if {$trigger == 3} { tk_popup .error [winfo pointerx .] [winfo pointery .] } else { tk_popup .error [winfo rootx .status] \ [expr [winfo rooty .status] + [winfo height .status]] } } # ------------------------------------------------------------------------------ proc lift {} { foreach ii {stack istack} { upvar #0 $ii st set st(t) $st(z) set st(z) $st(y) set st(y) $st(x) } } # ------------------------------------------------------------------------------ proc drop {} { foreach ii {stack istack} { upvar #0 $ii st set st(x) $st(y) set st(y) $st(z) set st(z) $st(t) } } # ------------------------------------------------------------------------------ proc move { from to } { global stack istack set stack($to) $stack($from) set istack($to) $istack($from) } # ------------------------------------------------------------------------------ proc populate { val } { foreach ii {stack istack} { upvar #0 $ii st foreach jj {x y z t} { set st($jj) $val } } } # ------------------------------------------------------------------------------ proc set_status { st } { global status FLAG PI switch $st { user { set status(user) [expr !$status(user)] set status(f) 0 toggle_user $status(user) show_x } f { if {!$status(f)} { set status(f) [expr !$status(f)] set status(g) 0 } } g { if {!$status(g)} { set status(g) [expr !$status(g)] set status(f) 0 } } fg_off { set status(f) 0 set status(g) 0 } BEGIN { set status(BEGIN) [expr !$status(BEGIN)] } DEG { set status(RAD) "" set status(RADfactor) $PI/180.0 show_x } RAD { set status(RAD) $st set status(RADfactor) 1.0 show_x } GRAD { set status(RAD) $st set status(RADfactor) [expr 0.9*$PI/180.0] show_x } PRGM { set status(PRGM) [expr !$status(PRGM)] } } if [winfo exists .status] { .status itemconfigure suser -text [expr $status(user) ? \"USER\" : \"\"] .status itemconfigure sf -text [expr $status(f) ? \"f\" : \" \"] .status itemconfigure sg -text [expr $status(g) ? \"g\" : \" \"] .status itemconfigure sbegin -text [expr $status(BEGIN) ? \"BEGIN\" : \" \"] .status itemconfigure srad -text $status(RAD) .status itemconfigure scomplex -text [expr $FLAG(8) ? \"C\" : \" \"] .status itemconfigure sprgm -text [expr $status(PRGM) ? \"PRGM\" : \"\"] } } # ------------------------------------------------------------------------------ proc count_digits { var } { set rc 0 for {set ii 0} {$ii < [string length $var]} {incr ii} { if {[string is digit [string index $var $ii]]} { incr rc } elseif {[string index $var $ii] == "e"} { break } } return $rc } # ------------------------------------------------------------------------------ proc func_digit { digit } { global status stack istack if {$status(num)} { if {!$status(liftlock)} {lift} if {$status(liftlock) < 2} {set istack(x) 0.0} set status(num) 0 if {$digit == "e+0"} { set digit "1$digit" } elseif {$digit == "."} { set digit "0." } set stack(x) $digit } else { set stack_x $stack(x) if {$digit == "e+0" && ([string first "e" $stack_x] > 0 || [count_digits $stack_x] > 7)} { set digit "" } set comma [string first "." $stack_x] if {[count_digits $stack_x] < 10 && !($digit == "." && $comma != -1)} { if {[string first "e" $stack_x] > 0} { regsub {([-+ ]?[0-9]+e[+-])[0-9]([0-9])$} $stack_x {\1\2} stack_x } set stack_x "$stack_x$digit" # Avoid integer overflow for 10-digit integers. Obsolete with Tcl/Tk >= 8.4? if {[count_digits $stack_x] == 10 && $comma == -1 && \ [string first "e" $stack_x] < 0} { set stack_x "$stack_x." } set stack(x) $stack_x } } set status(liftlock) 0 } # ------------------------------------------------------------------------------ proc func_sqrt {} { global FLAG stack if {$FLAG(8)} { move x u csqrt move u x } else { set stack(x) [expr sqrt($stack(x))] } } # ------------------------------------------------------------------------------ proc func_xpow2 {} { global FLAG stack istack if {$FLAG(8)} { set stack(x) [expr 1.0*$stack(x)*$stack(x) - $istack(x)*$istack(x)] set istack(x) [expr 2.0*$stack(s)*$istack(x)] } else { set stack(x) [expr pow($stack(x), 2)] } } # ------------------------------------------------------------------------------ proc func_exp {} { global FLAG stack istack if {$FLAG(8)} { set stack(x) [expr exp($stack(x))*cos($istack(x))] set istack(x) [expr exp($stack(s))*sin($istack(x))] } else { set stack(x) [expr exp($stack(x))] } } # The following are helper functions for the complex mode. They solely operate # on stack register u. # ------------------------------------------------------------------------------ proc cabs {} { global stack istack return [expr sqrt(1.0*$stack(u)*$stack(u) + 1.0*$istack(u)*$istack(u))] } # ------------------------------------------------------------------------------ proc cphi {} { global PI stack istack set ret [expr atan($istack(u)/$stack(u))] if {$stack(u) < 0.0} { set mod [expr $istack(u) >= 0.0 ? $PI : -$PI] } else { set mod 0.0 } set ret [expr $ret+$mod] return $ret } # ------------------------------------------------------------------------------ proc csqrt {} { global stack istack set tmp $stack(u) set xb [cabs] set stack(u) [expr sqrt(($stack(u) + $xb)/2.0)] set istack(u) [expr ($istack(u) < 0 ? -1.0 : 1.0)*sqrt((-$tmp + $xb)/2.0)] } # ------------------------------------------------------------------------------ proc cln {} { global PI stack istack set tmp $stack(u) set stack(u) [expr 0.5*log(1.0*$stack(u)*$stack(u)+1.0*$istack(u)*$istack(u))] if {$tmp != 0.0} { set mod 0.0 if {$tmp < 0.0} {set mod [expr $istack(u) >= 0.0 ? $PI : -$PI]} set istack(u) [expr atan($istack(u)/$tmp) + $mod] } else { set istack(u) [expr $istack(x) >= 0.0 ? $PI/2.0 : -$PI/2.0] } } # ------------------------------------------------------------------------------ proc func_ln {} { global FLAG stack istack if {$FLAG(8)} { if {$stack(x) == 0.0 && $istack(x) == 0.0} { error "" "" {ARITH INVALID} } else { move x u cln move u x } } else { if {$stack(x) == 0.0} { error "" "" {ARITH INVALID} } else { set stack(x) [expr log($stack(x))] } } } # ------------------------------------------------------------------------------ proc func_10powx {} { global PI status FLAG stack istack if {$FLAG(8)} { set stack(x) [expr pow(10.0,$stack(x))*cos($istack(x)*log(10.0))] set istack(x) [expr pow(10.0,$stack(s))*sin($istack(s)*log(10.0))] } else { set stack(x) [expr pow(10.0, $stack(x))] } } # ------------------------------------------------------------------------------ proc func_log10 {} { global FLAG stack istack if {$FLAG(8)} { if {$stack(x) == 0.0 && $istack(x) == 0.0} { error "" "" {ARITH INVALID} } else { move x u cln set stack(x) [expr $stack(u)/log(10.0)] set istack(x) [expr $istack(u)/log(10.0)] } } else { if {$stack(x) == 0.0} { error "" "" {ARITH INVALID} } else { set stack(x) [expr log10($stack(x))] } } } # ------------------------------------------------------------------------------ proc func_ypowx {} { global FLAG stack istack PI if {$FLAG(8)} { move y u set stack(y) [expr pow([cabs],$stack(x))*exp(-$istack(x)*[cphi])] set istack(y) [expr $stack(x)*[cphi] + $istack(x)*log([cabs])] set lx $stack(y) set stack(y) [expr cos($istack(y))*$stack(y)] set istack(y) [expr sin($istack(y))*$lx] } else { set stack(y) [expr pow($stack(y), $stack(x))] } drop } # ------------------------------------------------------------------------------ proc func_percent {} { global stack set stack(x) [expr ($stack(y)/100.0) * $stack(x)] } # ------------------------------------------------------------------------------ proc func_inv {} { global FLAG stack istack if {$FLAG(8)} { move x u set xb [expr pow([cabs],2)] set stack(x) [expr $stack(x)/$xb] set istack(x) [expr -$istack(s)/$xb] } else { set stack(x) [expr 1.0/$stack(x)] } } # ------------------------------------------------------------------------------ proc func_dpercent {} { global stack set stack(x) [expr ($stack(x)-$stack(y))/($stack(y)/100.0)] } # ------------------------------------------------------------------------------ proc func_dsp_mode { mode param } { global status storage if {$param == "I"} { if {$storage(I) < 0} { set param 0 } else { set param [expr int($storage(I)) > 9 ? 9 : int($storage(I))] } } set status(dispmode) $mode set status(dispprec) $param show_x } # ------------------------------------------------------------------------------ proc lookup_label { lbl } { global prgstat PRGM if {$lbl < 0} { set target "42_21_1[expr abs($lbl)]" } elseif {$lbl > 9} { set target "42_21_48_[expr int($lbl - 10)]" } else { set target "42_21_$lbl" } set tl -1 set wrap 0 set ll [expr $prgstat(curline)+1] while {!$wrap} { if {$ll > [llength $PRGM]} {set ll 0} if {[lindex $PRGM $ll] == "$target"} { set tl $ll break } elseif {$ll == $prgstat(curline)} { set wrap 1 } incr ll } return $tl } # ------------------------------------------------------------------------------ proc func_label { lbl } { show_x } # ------------------------------------------------------------------------------ proc func_sst { {ev 0} } { global HP15 status prgstat PRGM if {$status(PRGM)} { if {$ev == 0 || $ev == 2 || $ev == 4} { incr prgstat(curline) if {$prgstat(curline) >= [llength $PRGM]} { set prgstat(curline) 0 } show_curline } } else { if {$ev == 0 || $ev == 2 || $ev == 4} { if {$prgstat(curline) == 0 && [llength $PRGM] > 1} {incr prgstat(curline)} show_curline if {$ev == 0} {after $HP15(pause) {show_x}} } else { set prgstat(running) 1 prgm_step set prgstat(running) 0 show_x } } } # ------------------------------------------------------------------------------ proc func_bst { {ev 0} } { global HP15 status prgstat PRGM if {$status(PRGM) || $ev == 0 || $ev == 2 || $ev == 4} { if {$prgstat(curline) > 0} { incr prgstat(curline) -1 } else { set prgstat(curline) [expr [llength $PRGM] - 1] } show_curline } if {!$status(PRGM)} { if {$ev == 0 || $ev == 2 || $ev == 4} { set status(num) 1 if {$ev == 0} {after $HP15(pause) {show_x}} } else { show_x } } } # ------------------------------------------------------------------------------ proc func_gto_chs { trigger } { global status if {!$status(error)} {show_prgm $trigger} } # ------------------------------------------------------------------------------ proc func_gto { lbl } { global HP15 storage prgstat PRGM if {$lbl == "I"} { set lbl [expr int($storage(I))] if {$lbl < 0 && abs($lbl) <= [llength $PRGM]} { set ll [expr abs($lbl)] } elseif {$lbl >= 0 && $lbl <= $HP15(dataregs)} { set ll [lookup_label $lbl] } elseif {$lbl >= 20 && $lbl <= 24} { set ll [lookup_label [expr 19-$lbl]] } else { set ll -1 } } else { set ll [lookup_label $lbl] } if {$ll == -1} { error "" "" {ADDRESS} } else { set prgstat(curline) $ll } } # ------------------------------------------------------------------------------ proc func_gsb { lbl } { global HP15 prgstat if {$lbl == "I"} { set lbl [expr int($storage(I))] if {$lbl < 0 && abs($lbl) <= [llength $PRGM]} { set ll [expr abs($lbl)] } elseif {$lbl >= 0 && $lbl <= $HP15(dataregs)} { set ll [lookup_label $lbl] } elseif {$lbl >= 20 && $lbl <= 24} { set ll [lookup_label [expr 19-$lbl]] } else { set ll -1 } } else { set ll [lookup_label $lbl] } if {$ll == -1} { error "" "" {ADDRESS} } elseif {$prgstat(running)} { if {[llength $prgstat(rtnadr)] <= $HP15(gsbmax)} { lappend prgstat(rtnadr) [expr $prgstat(curline)+1] set prgstat(curline) $ll } else { error "" "" {RTN} } } else { prgm_run $ll } } # ------------------------------------------------------------------------------ proc func_hyp { func } { global FLAG stack istack if {$FLAG(8)} { switch $func { sin { set stack(x) [expr sinh($stack(x))*cos($istack(x))] set istack(x) [expr cosh($stack(s))*sin($istack(x))] } cos { set stack(x) [expr cosh($stack(x))*cos($istack(x))] set istack(x) [expr sinh($stack(s))*sin($istack(x))] } tan { set divi [expr pow(cosh($stack(x))*cos($istack(x)),2)+ \ pow(sinh($stack(s))*sin($istack(x)),2)] set stack(x) [expr sinh($stack(x))*cosh($stack(x))/$divi] set istack(x) [expr sin($istack(x))*cos($istack(x))/$divi] } } } else { set stack(x) [expr $func\h($stack(x))] } } # ------------------------------------------------------------------------------ proc func_ahyp { func } { global FLAG stack istack if {$FLAG(8)} { set stack(u) [expr 1.0*$stack(x)*$stack(x) - $istack(x)*$istack(x)] set istack(u) [expr 2.0*$stack(x)*$istack(x)] switch $func { sin { set stack(u) [expr $stack(u)+1.0] csqrt set stack(u) [expr $stack(x)+$stack(u)] set istack(u) [expr $istack(x)+$istack(u)] cln move u x } cos { set stack(u) [expr $stack(u)-1.0] csqrt set stack(u) [expr $stack(x)+$stack(u)] set istack(u) [expr $istack(x)+$istack(u)] cln set sg [expr $stack(s) < 0.0 ? -1.0 : 1.0] set stack(x) [expr $sg*$stack(u)] set istack(x) [expr $sg*$istack(u)] } tan { set divi [expr 1.0-2.0*$stack(x)+pow($stack(x),2)-pow($istack(x),2)] set stack(u) [expr (1.0-pow($stack(x),2)+pow($istack(x),2))/$divi] set istack(u) [expr -2.0*$stack(x)*$istack(x)/$divi] cln set stack(x) [expr 0.5*$stack(u)] set istack(x) [expr 0.5*$istack(u)] } } } else { switch $func { sin { set stack(x) [expr log($stack(x) + sqrt($stack(x)*$stack(x) + 1.0))] } cos { set stack(x) [expr log($stack(x) - sqrt($stack(x)*$stack(x) - 1.0))] } tan { set stack(x) [expr log(sqrt((1.0 + $stack(x)) / (1.0 - $stack(x))))] } } } } # ------------------------------------------------------------------------------ proc func_trign { func } { global status FLAG stack istack if {$FLAG(8)} { switch $func { sin { set stack(x) [expr sin($stack(x))*cosh($istack(x))] set istack(x) [expr cos($stack(s))*sinh($istack(x))] } cos { set stack(x) [expr cos($stack(x))*cosh($istack(x))] set istack(x) [expr -sin($stack(s))*sinh($istack(x))] } tan { set divi [expr cos(2.0*$stack(x))+cosh(2.0*$istack(x))] set stack(x) [expr sin(2.0*$stack(x))/$divi] set istack(x) [expr sinh(2.0*$istack(x))/$divi] } } } else { set stack(x) [expr $func\($stack(x)*$status(RADfactor))] } } # ------------------------------------------------------------------------------ proc func_atrign { func } { global status FLAG stack istack if {$FLAG(8)} { set stack(u) [expr $stack(x)*$stack(x) - $istack(x)*$istack(x)] set istack(u) [expr 2.0*$stack(x)*$istack(x)] switch $func { sin { set stack(u) [expr 1.0-$stack(u)] set istack(u) [expr -$istack(u)] csqrt set stack(u) [expr -$istack(x)+$stack(u)] set istack(u) [expr $stack(x)+$istack(u)] cln set stack(x) $istack(u) set istack(x) [expr -$stack(u)] } cos { set stack(u) [expr $stack(u)-1.0] csqrt set stack(u) [expr $stack(x)+$stack(u)] set istack(u) [expr $istack(x)+$istack(u)] cln set sg [expr $stack(s)*$istack(s) < 0.0 ? -1.0 : 1.0] set stack(x) [expr $sg*$istack(u)] set istack(x) [expr -$sg*$stack(u)] } tan { set divi [expr 1.0+2.0*$istack(x)+pow($istack(x),2)+pow($stack(x),2)] set stack(u) [expr (1.0-pow($istack(x),2)-pow($stack(x),2))/$divi] set istack(u) [expr 2.0*$stack(x)/$divi] cln set stack(x) [expr 0.5*$istack(u)] set istack(x) [expr -0.5*$stack(u)] } } } else { set stack(x) [expr a$func\($stack(x))/$status(RADfactor)] } } # ------------------------------------------------------------------------------ proc func_dim_mem {} { global HP15 stack storage set rr [expr abs(int($stack(x)))] if {$rr < 1} {set rr 1} if {$rr > $HP15(dataregs) + $HP15(prgmregsfree)} { error "" "" {DIM} } else { for {set ii [expr $rr+1]} {$ii <= $HP15(dataregs)} {incr ii} { array unset storage $ii } for {set ii [expr $HP15(dataregs)+1]} {$ii <= $rr} {incr ii} { set storage($ii) 0.0 } set HP15(dataregs) $rr mem_recalc } show_x } # ------------------------------------------------------------------------------ proc func_i { {ev 0} } { global HP15 status FLAG istack curdisp if {!$status(PRGM)} { if {$FLAG(8)} { if {$ev == 0 || $ev == 2 || $ev == 4} { set curdisp [format_number $istack(x)] if {$ev == 0} {after $HP15(pause) {show_x}} } else { after $HP15(pause) {show_x} } } else { if {$ev == 0 || $ev == 3 || $ev ==5} {error_handler {INDEX}} } } } # ------------------------------------------------------------------------------ proc func_I {} { global FLAG stack istack if {!$FLAG(8)} {func_sf 8} set istack(y) $stack(x) drop } # ------------------------------------------------------------------------------ proc func_pi {} { global stack istack PI lift set stack(x) $PI set istack(x) 0.0 } # ------------------------------------------------------------------------------ proc func_sf { flag } { global HP15 FLAG storage if {$flag == "I"} {set flag [expr int($storage(I))]} if {$flag == 8 && $HP15(prgmregsfree) < 5} { error "" "" {DIM} } if {$flag >= 0 && $flag <= 9} { set FLAG($flag) 1 set_status NIL show_x } else { error "" "" {FLAG} } } # ------------------------------------------------------------------------------ proc func_cf { flag } { global FLAG istack storage if {$flag == "I"} {set flag [expr int($storage(I))]} if {$flag >= 0 && $flag <= 9} { if {$flag == 8} {foreach ii {LSTx x y z t u s} {set istack($ii) 0.0 }} set FLAG($flag) 0 set_status NIL show_x } else { error "" "" {FLAG} } } # ------------------------------------------------------------------------------ proc show_flags { trigger } { global LAYOUT status FLAG if {[winfo exists .flags]} {destroy .flags} menu .flags -tearoff 0 -title "Flags" -font $LAYOUT(FnMenu) if {$status(PRGM)} { set st normal } else { set st disabled } for {set ii 0} {$ii <= 9} {incr ii} { .flags add command -label "$ii: $FLAG($ii)" -state $st \ -command "dispatch_key 43_6_$ii" } if {$trigger == 3} { tk_popup .flags [winfo pointerx .] [winfo pointery .] } else { tk_popup .flags [winfo rootx .btn_29.gbtn] \ [expr [winfo rooty .btn_29.gbtn]+[winfo height .btn_29.gbtn]] } } # ------------------------------------------------------------------------------ proc func_Finq { flag } { global prgstat storage FLAG if {$prgstat(running)} { if {$flag == "I"} {set flag [expr int($storage(I))]} if {$flag >= 0 && $flag <= 9} { if {$FLAG($flag) == 0} {incr prgstat(curline) 2} } else { error "" "" {FLAG} } } } # ------------------------------------------------------------------------------ proc func_clearsumregs {} { global HP15 stack istack storage if {$HP15(dataregs) < 7} { error "" "" {INDEX} } else { for {set ii 2} {$ii < 7} {incr ii} { set storage($ii) 0.0 } } foreach ii {x y z t} { set stack($ii) 0.0 set istack($ii) 0.0 } } # ------------------------------------------------------------------------------ proc disp_scroll { inc } { global status if {$status(PRGM)} { if {$inc >= 0.0} { dispatch_key 21 } else { dispatch_key 43_21 } } else { func_roll [expr $inc >= 0 ? 3 : 1] } } # ------------------------------------------------------------------------------ proc func_roll { cnt } { global status set status(num) 1 for {set ii 0} {$ii < $cnt} {incr ii} { foreach jj {stack istack} { upvar #0 $jj st set tmp $st(y) set st(y) $st(z) set st(z) $st(t) set st(t) $st(x) set st(x) $tmp } } show_x } # ------------------------------------------------------------------------------ proc func_chs {} { global status stack if {$status(num)} { set stack(x) [expr -$stack(x)] } else { if {[string first "e" $stack(x)] > 0} { set stack(x) [string map {e+ e- e- e+} $stack(x)] } else { if {[string index $stack(x) 0] == "-"} { set stack(x) [string range "$stack(x)" 1 end] } else { set stack(x) "-$stack(x)" } } } } # ------------------------------------------------------------------------------ proc func_abs {} { global FLAG stack istack if {$FLAG(8)} { move x u set stack(x) [cabs] set istack(x) 0.0 } else { set stack(x) [expr abs($stack(x))] } } # ------------------------------------------------------------------------------ proc func_xexchg { param } { global stack storage set param [GETREG $param] set tmp $storage($param) set storage($param) $stack(x) set stack(x) $tmp } # ------------------------------------------------------------------------------ proc func_dse { param } { global storage prgstat PRGM set param [GETREG $param] set nn [expr int($storage($param))] set yy [expr abs(($storage($param) - $nn)*1E3)] set xx [expr int($yy)] set yy [expr int(100.0 * ($yy - $xx))] set nn [expr $nn-[expr $yy == 0.0 ? 1 : $yy]] if {$nn <= $xx} { if {$prgstat(curline) < [llength $PRGM]} {incr prgstat(curline) 2} } set storage($param) "$nn.[format "%03d" $xx][format "%02d" $yy]" } # ------------------------------------------------------------------------------ proc func_isg { param } { global storage prgstat PRGM set param [GETREG $param] set nn [expr int($storage($param))] set yy [expr abs(($storage($param) - $nn)*1E3)] set xx [expr int($yy)] set yy [expr int(100.0 * ($yy - $xx))] if {$yy == 0.0} {set yy 1} set nn [expr $nn+[expr $yy == 0.0 ? 1 : $yy]] if {$nn > $xx} { if {$prgstat(curline) < [llength $PRGM]} {incr prgstat(curline) 2} } set storage($param) "$nn.[format "%03d" $xx][format "%02d" $yy]" } # ------------------------------------------------------------------------------ proc regula_falsi { lbl x0 x1 } { global stack prgstat set ebs 1E-14 set iter 0 while {1} { populate $x1 func_gsb $lbl set f_x1 $stack(x) populate $x0 func_gsb $lbl set f_x0 $stack(x) set x2 [expr $x0 - $f_x0 * (($x0 - $x1)/($f_x0 - $f_x1))] populate $x2 func_gsb $lbl set f_x2 $stack(x) if {$f_x0 == $f_x2 || [incr iter] > $prgstat(maxiter)} { error "" "" {SOLVE} } set x0 $x1 set x1 $x2 if {[expr abs($x0 - $x1)] <= $ebs} {break} } set stack(z) $f_x2 set stack(y) $x1 set stack(x) $x2 } # ------------------------------------------------------------------------------ proc func_solve { lbl } { global HP15 status stack if {$status(solve)} {error "" "" {RECURSION}} set status(solve) 1 set ll [lookup_label $lbl] if {$HP15(prgmregsfree) < 5} { error "" "" {DIM} } elseif {$ll == -1} { error "" "" {ADDRESS} } else { if {$stack(x) < $stack(y)} {func_xy} regula_falsi $lbl $stack(y) $stack(x) } set status(solve) 0 } # ------------------------------------------------------------------------------ proc simpson { lbl lb ub steps } { global stack set st [expr ($ub-$lb)/($steps*1.0)] set res 0.0 for {set ii 0} {$ii < $steps} {incr ii 2} { populate [expr $lb+$ii*$st] func_gsb $lbl set res [expr $res+$stack(x)] populate [expr $lb+($ii+1)*$st] func_gsb $lbl set res [expr $res+4.0*$stack(x)] populate [expr $lb+($ii+2)*$st] func_gsb $lbl set res [expr $res+$stack(x)] } return [expr $res*$st/3.0] } # ------------------------------------------------------------------------------ proc func_integrate { lbl } { global HP15 status stack if {$status(integrate)} {error "" "" {RECURSION}} set status(integrate) 1 set ll [lookup_label $lbl] if {$HP15(prgmregsfree) < 23} { error "" "" {DIM} } elseif {$ll == -1} { error "" "" {ADDRESS} } else { set lb $stack(y) set ub $stack(x) set steps 32 set res1 0.0 set res2 0.0 set delta 0.0 while {1} { if {[catch {set res [simpson $lbl $lb $ub $steps]} einf]} { error "" "" {INTERRUPT} return } if {$status(dispmode) == "FIX"} { set log 0 } else { set log [expr $res != 0 ? int(floor(log10(abs($res)))) : 0] } set prec [expr 0.5 * pow(10, -$status(dispprec)+$log)] set delta [expr $delta + (($ub - $lb) / $steps * $prec)] if {[expr abs($res1-$res)] < $delta || [expr abs($res2-$res)] < $delta} { break } else { set res1 $res2 set res2 $res } set steps [expr 2*$steps] } set stack(t) $lb set stack(z) $ub set status(integrate) 0 set status(num) 1 set stack(y) $delta set stack(x) $res } } # ------------------------------------------------------------------------------ proc func_clearprgm {} { global HP15 status prgstat PRGM set prgstat(curline) 0 set prgstat(interrupt) 0 if {$status(PRGM)} { set HP15(prgmname) "" set prgstat(running) 0 set prgstat(rtnadr) {0} set PRGM {{}} show_curline mem_recalc } else { show_x } } # ------------------------------------------------------------------------------ proc func_clearreg {} { global HP15 storage for {set ii 0} {$ii <= $HP15(dataregs)} {incr ii} { set storage($ii) 0.0 } set storage(I) 0.0 } # ------------------------------------------------------------------------------ proc func_rnd {} { global status stack set stack(x) [format "%.$status(dispprec)f" $stack(x)] } # ------------------------------------------------------------------------------ proc func_xy {} { global status foreach ii {stack istack} { upvar #0 $ii st set tmp $st(y) set st(y) $st(x) set st(x) $tmp } } # ------------------------------------------------------------------------------ proc func_prefix { {ev 0} } { global HP15 status stack curdisp if {!$status(PRGM)} { if {$ev == 0 || $ev == 2 || $ev == 4} { set curdisp " [string map {. ""} [format "%.10e" [expr abs($stack(x))]]]" if {$ev == 0} {after $HP15(pause) {show_x}} } else { after $HP15(pause) {show_x} } } } # ------------------------------------------------------------------------------ proc func_bs {} { global status stack FLAG prgstat PRGM if {$status(PRGM)} { if {$prgstat(curline) > 0} { set PRGM [lreplace $PRGM $prgstat(curline) $prgstat(curline)] incr prgstat(curline) -1 mem_recalc show_curline } } else { if {$FLAG(9)} { set FLAG(9) 0 } elseif {$status(num)} { set stack(x) 0.0 set status(liftlock) 2 } else { regsub {e[+-]0?$} $stack(x) "e" temp regsub {^-[0-9]$} $temp "" temp if {[string length $temp] > 1} { # Remove period added to 10-digit integers in 'func_digit' if {[count_digits $temp] == 10 && [string index $temp end] == "."} { set temp "[string range $temp 0 end-1]" } set stack(x) "[string range $temp 0 end-1]" } else { set status(liftlock) 2 set status(num) 1 set stack(x) 0.0 } } } } # ------------------------------------------------------------------------------ proc func_clx {} { global status stack set stack(x) 0.0 set status(liftlock) 3 } # ------------------------------------------------------------------------------ proc clearall {} { populate 0.0 func_clearreg func_clx func_digit 0 dispatch_key 20 move x u move x m } # ------------------------------------------------------------------------------ proc func_frac {} { global stack set stack(x) [expr ($stack(x) - int($stack(x)))*1.0] } # ------------------------------------------------------------------------------ proc GETREG { param } { global HP15 storage if {$param == "(i)"} {set param [expr int($storage(I))]} if {($param < 0 || $param > $HP15(dataregs)) && $param != "I"} { error "" "" {INDEX} return } return $param } # ------------------------------------------------------------------------------ proc func_sto { param } { global stack storage set storage([GETREG $param ]) [expr $stack(x)*1.0] show_x } # ------------------------------------------------------------------------------ proc func_sto_oper { fn param } { global stack storage set param [GETREG $param ] set storage($param) [expr $storage($param) $fn $stack(x)*1.0] show_x } # ------------------------------------------------------------------------------ proc func_int {} { global stack set stack(x) [expr 1.0*int($stack(x))] } # ------------------------------------------------------------------------------ proc toggle_user { mode } { if {$mode} { for {set ii 1} {$ii < 5} {incr ii} { bind .btn_1$ii.fbtn "