; 2026.1010 Mueck_f42.txt
; Program suite for all Mueck_f42 Free42 skins - mick.mueck@mac.com

; NOTE: After installing this suite, go into program mode and enter XEQ "LOCK". 
; It'll look like you're adding a line of code, but you're actually performing 
; a write protect function. That will avoid future grief if you accidentally 
; modify or delete any code. The program pointer turns "gray" to indicate the 
; LOCK was successful. The process can similarly be undone with XEQ "UNLOCK".

; To run this skin in Plus42, use the Mueck_p42 program suite instead.
; It's the same thing but without TVM (because Plus42 has its own TVM).

; Usage instructions for .CONST, .POLY and TVM are given in the 
; headers of each of those programs. 

;--------------------------------------------------------------
; FIX02 Toggles the current display state with FIX 02
; Flags 40-41 store FIX/SCI/ENG/ALL, flags 36-39 store #digits
; FIX 02 defined by: Flags 36-41 CLEAR except for 38 & 40 
;--------------------------------------------------------------
LBL ".FIX02"
FUNC 00
SF 25
FC? 41       ; See if the current display state is FIX 02
FC? 40
GTO 01       ; Not FIX 02
FC? 39
FC? 38
GTO 01       ; Not FIX 02
FC? 37
FS? 36
GTO 01       ; Not FIX 02
RCL ".DISP"  ; Is FIX 02, recall saved display state
FC? 25
GTO 01       ; .DISP is uninitialized, the current state is FIX 02
ENTER
COMPLEX
36.41
STOFLAG      ; Set the previously saved display state 
RTN
LBL 01       ; Not FIX 02. Save the display state and set FIX 02
RCLFLAG      ; In case .DISP hasn't been defined yet
COMPLEX
X<>Y
STO ".DISP"  ; Save the current display state
FIX 02
RTN

;--------------------------------------------------------------
; X↑3 → X↑9   Hot-keys ⌥3 → ⌥9   Mimics a built-in function
;--------------------------------------------------------------
LBL ".X↑9"
FUNC 11
9
GTO a

LBL ".X↑8"
FUNC 11
8
GTO a

LBL ".X↑7"
FUNC 11
7
GTO a

LBL ".X↑6"
FUNC 11
6
GTO a

LBL ".X↑5"
FUNC 11
5
GTO a

LBL ".X↑4"
FUNC 11
4
GTO a

LBL ".X↑3"
FUNC 11
3
GTO a

LBL a
SF 25
Y↑X
FS? 25
RTN
ERRNO
RTNERR IND ST X


;--------------------------------------------------------------
; 3√X → 9√X   Hot-keys ⇧⌥3 → ⇧⌥9   Mimics a built-in function
; Yields intuitive results e.g. ³√-27 = -3 vs 3 angle 60°
; Temporarily uses FLAG 25 - SET if exponent ODD, CLEAR if exponent EVEN 
;--------------------------------------------------------------
LBL ".9√X"
FUNC 11
SF 25
9
GTO a

LBL ".8√X"
FUNC 11
CF 25
8
GTO a

LBL ".7√X"
FUNC 11
SF 25
7
GTO a

LBL ".6√X"
FUNC 11
CF 25
6
GTO a

LBL ".5√X"
FUNC 11
SF 25
5
GTO a

LBL ".4√X"
FUNC 11
CF 25
4
GTO a

LBL ".3√X"
FUNC 11
SF 25
3 
GTO a

LBL a
X<>Y
LSTO "X"	; Save X-register to put into LASTx later on
FC? 25
GTO b		; GTO b if exponent is EVEN, Flag 25 has served it's purpose so SET it
REAL?
SKIP
GTO b		; GTO b if exponent is ODD and X is NOT REAL
X≥0?
GTO b		; GTO b if exponent is ODD and X is REAL and POSITIVE
+/-		; Negate X (performing e.g. ⁵√-X → -⁵√X)
X<>Y
-1		; indicates exponent is ODD, and X is REAL and NEGATIVE and NEGATED
GTO c
LBL b
X<>Y
1
LBL c
SF 25		; Now start using flag 25 for error conditions
LSTO "M"	; M=-1 if X is REAL & NEGATIVE & NEGATED and exponent ODD, else M=1
R↓
1/X		; this is where errors can start occurring 
Y↑X
RCL× "M"	; Negate the result if X is REAL & NEGATIVE and exponent ODD
RCL "X"
STO ST L
X<>Y
FS? 25
RTN
ERRNO
RTNERR IND ST X

;--------------------------------------------------------------
; E↑iX   Hot-key ⇧⌥e   Mimics a built-in function
;--------------------------------------------------------------
LBL ".E↑iX" 
FUNC 11
SF 25
-1
SQRT
×
E^X
FS? 25
RTN
ERRNO
RTNERR IND ST X

;--------------------------------------------------------------
; √-1   Hot-keys i and j  (don't use FUNC because it will void LASTx)
;--------------------------------------------------------------
LBL ".i"
CSLD?
CLX
LASTX		; Preserve LASTx
LSTO "X"
CLX
-1		; This way you don't have to worry about the complex MODE setting 
SQRT
STO ST L	; Store answer in LASTX
CLX
RCL "X"
X<> ST L
RTN

;--------------------------------------------------------------
; RSSdB & RDSdB   i.e. dB(√((dB⁻¹Y)² ± (dB⁻¹X)²)
; Hot-keys ⌃⌥v and ⌃⇧⌥v   Mimics a built-in function
;--------------------------------------------------------------
LBL ".RDSdB"
FUNC 21
SF 25
20
/
10^X
X^2
X<>Y
20
/
10^X
X^2
X<>Y
-
SQRT
LOG
20
*
FS? 25
RTN
ERRNO
RTNERR IND ST X

LBL ".RSSdB"
FUNC 21
SF 25
20
/
10^X
X^2
X<>Y
20
/
10^X
X^2
+
SQRT
LOG
20
*
FS? 25
RTN
ERRNO
RTNERR IND ST X

;--------------------------------------------------------------
; RSS & RDS i.e. √(Y²±X²)   Hot-keys ⌥v and ⇧⌥v   Mimics a built-in function
;--------------------------------------------------------------
LBL ".RDS"
FUNC 21
SF 25
X^2
X<>Y
X^2
X<>Y
-
SQRT
FS? 25
RTN
ERRNO
RTNERR IND ST X

LBL ".RSS"
FUNC 21
SF 25
X^2
X<>Y
X^2
+
SQRT
FS? 25
RTN
ERRNO
RTNERR IND ST X

;--------------------------------------------------------------
; dB & dB⁻¹   Hot-keys ⌥d and ⇧⌥d    Mimics a built-in function
;--------------------------------------------------------------
LBL ".dB-1"
FUNC 11
SF 25
20
/
10^X
FS? 25
RTN
ERRNO
RTNERR IND ST X

LBL ".dB" 
FUNC 11
SF 25
LOG
20
×
FS? 25
RTN
ERRNO
RTNERR IND ST X

;--------------------------------------------------------------
; LOG₂ & 2↑X   Hot-keys ⌥b and ⇧⌥b   Mimics a built-in function
;--------------------------------------------------------------
LBL ".2↑X"
FUNC 11
SF 25
2
X<>Y
Y^X
FS? 25
RTN
ERRNO
RTNERR IND ST X

LBL ".LOG2" 
FUNC 11
SF 25
LOG
2
LOG
/
FS? 25
RTN
ERRNO
RTNERR IND ST X

;--------------------------------------------------------------
; .CONST 2026.1010 - 4STK and NSTK compliant
; If you're unsure what the symbol on the button is, do ⇧Button
;   to just reveal the description without entering any data.
;   Note: doing that voids any CSLD (Caller Stack Lift Disable)
; To tailor the CONSTANT menu to your own needs:
; - Edit the contents of each menu level as needed.
; - Maintain the systematic labeling used in each level. 
; - Add or delete levels as needed (8 at the most).
; - Edit "NUMBER OF MENU LEVELS USED" (in TWO places)
; Uses LBLs 00-05 and reserves LBLs 10→16 → 80→86
;--------------------------------------------------------------

LBL ".CONST"
XEQ d            ; Initialization
;--------------------------------------------------------------
LBL 00           ; RUN LOOP (ONLY modifies the Alpha-register)
;--------------------------------------------------------------
CLMENU
KEY 7 XEQ 02     ; Menu UP
KEY 8 XEQ 01     ; Menu DOWN
KEY 9 GTO 03     ; EXIT
XEQ IND ".conl"  ; Build the currently selected menu level
CLA
ARCL ".cona"     ; Restore the Alpha-register
MENU1            ; Won't be dismissed when exiting other menus
STOP             ; Menu functions start their XEQs from here
GTO 00           ; Ideally this instruction never gets executed
;--------------------------------------------------------------
LBL d            ; INITIALIZATION
FUNC 00
XASTO ".cona"    ; Save the Alpha-register
10               ; Menu level must be a multiple of 10
STO ".conl"      ; Set the initial menu level
RTN
;--------------------------------------------------------------
LBL 01           ; MENU DOWN
FUNC 00
10               ; Menu level must be a multiple of 10
STO/ ".conl"
3                ; <~~~~~~ "NUMBER OF MENU LEVELS USED" (Max=8)
X=? ".conl"
STO- ".conl"
ISG ".conl"
NOP
GTO a
LBL 02           ; MENU UP
FUNC 00
10               ; Menu level must be a multiple of 10
STO/ ".conl"
3                ; <~~~~~~ "NUMBER OF MENU LEVELS USED" (Max=8)
DSE ".conl"
GTO a
STO ".conl"
LBL a
DROP
STO* ".conl"
RTN
;--------------------------------------------------------------
LBL 03           ; EXIT
CLV ".cona"
CLV ".conl"
CLMENU
EXITALL
RTN
;--------------------------------------------------------------
LBL 04           ; A 500msec pause (PSE is just too long)
XEQ a
GTO 00
LBL a
FUNC 00
AVIEW 
TIME
0.00005          ; 500ms
HMS+
LBL 05
TIME
X>Y?
GTO c
DROP
GTO 05
LBL c
CLD
RTN
;--------------------------------------------------------------
LBL 10           ; LEVEL 1 menu
"g"
KEY 1 XEQ 11
"G"
KEY 2 XEQ 12
"c"
KEY 3 XEQ 13
"h"
KEY 4 XEQ 14
"R"
KEY 5 XEQ 15
"Na"
KEY 6 XEQ 16
RTN

LBL 11           ; Button 1 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
9.80665
LBL a
"Earth Gravity"
GTO 04
LBL 12           ; Button 2 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
6.6743E-11
LBL a
"Gravitational"
├" Constant"
GTO 04
LBL 13           ; Button 3 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
299792458
LBL a
"Speed of Light"
GTO 04
LBL 14           ; Button 4 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
6.62607015E-34
LBL a
"Planck Constant"
GTO 04
LBL 15           ; Button 5 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
8.314462618
LBL a
"Gas Constant"
GTO 04
LBL 16           ; Button 6 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
6.02214076E23
LBL a
"Avogadro Number"
GTO 04
;--------------------------------------------------------------
LBL 20           ; LEVEL 2 menu
"k"
KEY 1 XEQ 21
"q"
KEY 2 XEQ 22
"e0"
KEY 3 XEQ 23
"μ0"
KEY 4 XEQ 24
"Z0"
KEY 5 XEQ 25
" "
KEY 6 XEQ 26
RTN

LBL 21           ; Button 1 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
1.380649ᴇ-23
LBL a
"Boltzmann "
├"Constant"
GTO 04
LBL 22           ; Button 2 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
1.602176634ᴇ-19
LBL a
"Electron Charge"
GTO 04
LBL 23           ; Button 3 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
8.8541878128ᴇ-12
LBL a
"Permittivity of"
├" Vacuum"
GTO 04
LBL 24           ; Button 4 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
1.25663706212ᴇ-6
LBL a
"Permeability of"
├" Vacuum"
GTO 04
LBL 25           ; Button 5 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
376.730313668
LBL a
"Impedance of"
├" Vacuum"
GTO 04
LBL 26           ; Button 6-------------
" "
GTO 04

;--------------------------------------------------------------
LBL 30           ; LEVEL 3 menu
"er_ox"
KEY 1 XEQ 31
"er_ni"
KEY 2 XEQ 32
"P_Al"
KEY 3 XEQ 33
"P_Cu"
KEY 4 XEQ 34
"µn"
KEY 5 XEQ 35
"µp"
KEY 6 XEQ 36
RTN

LBL 31           ; Button 1 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
3.9
LBL a
"SiO2 Rel "
├"Permittivity"
GTO 04
LBL 32           ; Button 2 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
7.5
LBL a
"Si3N4 Rel "
├"Permittivity"
GTO 04
LBL 33           ; Button 3 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
2.65E-8
LBL a
"Aluminum "
├"Resistivity"
GTO 04
LBL 34           ; Button 4 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
1.68E-8
LBL a
"Copper "
├"Resistivity"
GTO 04
LBL 35           ; Button 5 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
0.136
LBL a
"Si Electron "
├"Mobility"
GTO 04
LBL 36           ; Button 6 <--------------
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the constant name only
CSLD?            ; Must use KEYX, not KEYG
CLX
0.048
LBL a
"Si Hole "
├"Mobility"
GTO 04

;----------------------------------------------------------------------------
; 2026.1010: ".POLY" - Mick Mueck mick.mueck@mac.com
;----------------------------------------------------------------------------
; Solves up to 4th order polynomials using exact formulas.
; 4STK and NSTK compliant.
; Uses Free42 enhancements so this code won't run on a real calculator.
; Uses LBLs unused by .CONST & TVM: 05-09,17-19,27-29,37-39,99

; MENU Level 1:
; Coefficients entered via the menus are stored in registers named:
;       .X^4, .X^3, .X^2, .X^1, .X^0
; SOLV will solve the polynomial implied by the highest order non-zero
;   coefficient. Note that ⇧SOLV resets all coefficients to zero.
; Roots are stored in registers named  ".√4"→".√1"
;   quadratic uses .√2→.√1, cubic uses .√3→.√1, quartic uses .√4→.√1
; Coefficients are NOT reset when you start .POLY in case you need to
;   leave .POLY to calculate the coefficients.
; Any variables not used by a polynomial solution are reset to zero.
; To VIEW a coefficient for ~1 sec without disrupting the stack, ⇧press
;   the coefficient's menu button. You can also do RCL (or STO or VIEW)
;   and select a coefficient from that menu.

; MENU Level 2:
; A menu GUI is nice, but I prefer entering the coefficients onto the
;   stack and doing XEQ ".QUAD" (or ".CUBIC" or ".QRTC)"
;   Because of the 4 level stack limitation, when doing XEQ ".QRTC" you 
;   must modify the coefficients so .X^4=1. That also applies for NSTK.
; When using this stack method, the coefficients are also stored in the
;   .X^n registers so that you can subsequently use the SOLV method on  
;   them if a typo was made with e.g. just one of the coefficients.

LBL ".POLY"
XEQ c            ; Initialization
;----------------------------------------------------------------------------
LBL 99           ; MAIN RUN LOOP (ONLY modifies the Alpha-register)
;----------------------------------------------------------------------------
XEQ d            ; Make RCL menu variable order match TVM's menu
CLMENU
0>? ".plyl"      ; Build the currently selected menu level
GTO a
"X^4"
XEQ e            ; Badge menu label with "." if zero, "!" if illegal
KEY 1 GTO 07     ; "X^4"
"X^3"
XEQ e            ; Badge menu label with "." if zero, "!" if illegal
KEY 2 GTO 08     ; "X^3"
"X^2"
XEQ e            ; Badge menu label with "." if zero, "!" if illegal
KEY 3 GTO 09     ; "X^2"
"X^1"
XEQ e            ; Badge menu label with "." if zero, "!" if illegal
KEY 4 GTO 17     ; "X^1"
"X^0"
XEQ e            ; Badge menu label with "." if zero, "!" if illegal
KEY 5 GTO 18     ; "X^0"
"SOLV"
KEY 6 GTO 19     ; "SOLV"
GTO b

LBL a            ; Create the 2nd Level menu
"QUAD"
KEY 1 GTO 27     ; Quadratic (Stack entry method)
"CUBIC"
KEY 2 GTO 28     ; Cubic     (Stack entry method)
"QRTC"
KEY 3 GTO 29     ; Quartic   (Stack entry method)
" "
KEY 4 GTO 99     ; NOP
" "
KEY 5 GTO 99     ; NOP
" "
KEY 6 GTO 99     ; NOP
LBL b
KEY 7 GTO 37     ; Menu UP
KEY 8 GTO 37     ; Menu DOWN
KEY 9 GTO 38     ; EXIT
CLA
ARCL ".plya"     ; Restore the Alpha-register
MENU1            ; Robust against being dismissed when exiting other menus
STOP             ; Menu functions start their XEQs from this location
GTO 99           ; Ideally this instruction never gets executed
;----------------------------------------------------------------------------
LBL c            ; POLY INITIALIZATION (modifies X-register so use FUNC 00)
FUNC 00
XASTO ".plya"    ; Save the Alpha-register
1
STO ".plyl"      ; Set the POLY menu level (instead of using a global flag)
CLV ".plyq"      ; Just in case some error left this still defined
CLV ".plyc"      ; Just in case some error left this still defined
RTN
;----------------------------------------------------------------------------
LBL d            ; Delete/recreate X^4 → X^0 in reverse order to match what
;                  you see when you press RCL. Zero them if they don't exist.
FUNC 00
XSTR ".√4"
XEQ a
XSTR ".√3"
XEQ a
XSTR ".√2"
XEQ a
XSTR ".√1"
XEQ a
XSTR ".X^0"
XEQ a
XSTR ".X^1"
XEQ a
XSTR ".X^2"
XEQ a
XSTR ".X^3"
XEQ a
XSTR ".X^4"
XEQ a
CLV ".plyv"
RTN
; CLEAR and RECREATE the variable referenced by X. Default value is in Y.
LBL a
SF 25
RCL IND ST X     ; Make sure it exists
FC?C 25
0                ; default value, Y-register now still holds variable name
CLV IND ST Y
STO IND ST Y
RTN
;----------------------------------------------------------------------------
LBL e            ; For creating MENU hints "!" → Illegal, "." → =0
FUNC 00
ASTO ST X
REV
XSTR "."
APPEND
REV
RCL IND ST X     ; RCL variable prefixed by ".". XEQ 01 guaranteed existence.
REAL?
GTO a
├" !"
RTN
LBL a
X=0?
├"."
RTN
;----------------------------------------------------------------------------
LBL 37           ; Invert the menu level
XEQ a            ; FUNC will protect the stack & LASTX
GTO 99           ; Back to the Run Loop
LBL a
FUNC 00
-1
STO* ".plyl"
RTN
;----------------------------------------------------------------------------
LBL 38           ; EXIT - restore affected original environment
CLA
ARCL ".plya"     ; Restore the Alpha-register
CLV ".plya"
CLV ".plyv"
CLV ".plyl"
CLV ".plyq"      ; Just in case some error left this still defined
CLV ".plyc"      ; Just in case some error left this still defined
CLMENU           ; From page 148 of the HP42S manual
EXITALL
;RTN             ; If execution stopped at some random place due to an
                 ; error, this will RTN there and likely yield an error.
STOP             ; May leave debris on the stack, but better than RTN
;----------------------------------------------------------------------------
LBL 07           ; X^4
".X^4"
XEQ 39
GTO 99           ; Back to the Run Loop
;----------------------------------------------------------------------------
LBL 08           ; X^3
".X^3"
XEQ 39
GTO 99           ; Back to the Run Loop
;----------------------------------------------------------------------------
LBL 09           ; X^2
".X^2"
XEQ 39
GTO 99           ; Back to the Run Loop
;----------------------------------------------------------------------------
LBL 17           ; X^1
".X^1"
XEQ 39
GTO 99           ; Back to the Run Loop
;----------------------------------------------------------------------------
LBL 18           ; X^0
".X^0"
XEQ 39
GTO 99           ; Back to the Run Loop
;----------------------------------------------------------------------------
LBL 39           ; Manage STO & VIEW button actions for X^4 → X^0
;                  This routine does NOT modify the stack or LASTx 
ASTO ".plyv"     ; Store the coefficient name into ".plyv"
FS? 64           ; See if shift was pressed
GTO a            ; Yes, VIEW the variable for 1 sec if it exists
; STORE Result
SF 25            ; Check for trying a STO with an empty NSTK
STO ST X
FC?C 25
GTO b            ; Trying to STO an empty X-register :-/
REAL?            ; Ensure X is legal or isn't blank in NSTK
SKIP
GTO c            ; Trying to STO a number that isn't REAL
STO IND ".plyv"  ; Store the error checked variable
├"= "            ; "=" signifies a STO operation 
ARCL ST X
GTO d            ; VIEW the Alpha-register for 1 sec

; VIEW Result 
LBL a            ; ⇧MENU: VIEW the variable for 1 sec if it exists 
XEQ e            ; Existence check of variable in the Alpha-register 
GTO b            ; Variable doesn't exist
├": "            ; ":" signifies a VIEW operation
ARCL IND ".plyv"
LBL d            ; Show the Alpha-register for 1 second
AVIEW
PSE
CLD
RTN
LBL c
├": Not REAL"
AVIEW            ; View an error message that you need to dismiss
RTN
LBL b
├": Nonexistent"
AVIEW            ; View an error message that you need to dismiss
RTN

LBL e            ; Alpha-register variable name existence test  
FUNC 00
ASTO ST X        ; Store the variable name into X
SF 25
RCL IND ST X 
FC?C 25
RTNYES           ; Does not exist
RTNNO            ; Does exist
;----------------------------------------------------------------------------
LBL 19           ; SOLV
FC? 64           ; See if shift was pressed
GTO 06           ; No, Process the calculations 
XEQ a
GTO 99           ; Back to the Run Loop
LBL a
FUNC 00
0
STO ".X^0"
STO ".X^1"
STO ".X^2"
STO ".X^3"
STO ".X^4"
RTN
;----------------------------------------------------------------------------
LBL 06           ; Solves the polynomial, maintains stack & Alpha-register
XEQ a
GTO 99           ; Back to the Run Loop
LBL a
0≠? ".X^4"       ; If the coefficient of X^4 ≠ 0 go to quartic solver
GTO b
0≠? ".X^3"       ; If the coefficient of X^3 ≠ 0 go to cubic solver
GTO c
0≠? ".X^2"       ; If the coefficient of X^2 ≠ 0 go to quadratic solver
GTO d
0≠? ".X^1"       ; If the coefficient of X^1 ≠ 0 go to linear solver
GTO e
"Unsolvable"
AVIEW            ; Show error message for 1 second
PSE
CLD
RTN
LBL b            ; Get the stack in order for a .QUAD call
FUNC 04
RCL  ".X^3"
RCL/ ".X^4"
RCL  ".X^2"
RCL/ ".X^4"
RCL  ".X^1"
RCL/ ".X^4"
RCL  ".X^0"
RCL/ ".X^4"
XEQ ".QRTC"
RTN              ; Back to the Run Loop
LBL c            ; Get the stack in order for a .CUBIC call
FUNC 03
RCL ".X^3"
RCL ".X^2"
RCL ".X^1"
RCL ".X^0"       ; All menu register coefficients now on the stack
XEQ ".CUBIC"
RTN              ; Back to the Run Loop
LBL d            ; Get the stack in order for a .QUAD call 
FUNC 02
RCL ".X^2"
RCL ".X^1"
RCL ".X^0"       ; All menu register coefficients now on the stack
XEQ ".QUAD"
RTN              ; Back to the Run Loop
LBL e            ; Perform the simple linear algebra calculation
FUNC 01 
RCL ".X^0"
RCL/ ".X^1"
STO ".√1"
RTN              ; Back to the Run Loop
;----------------------------------------------------------------------------
LBL 27           ; Quadratic: DROPs 2 elements, returns 2 roots
XEQ ".QUAD"      ; Does error checking for stack depth and REAL elements
GTO 99           ; Back to the Run Loop
;----------------------------------------------------------------------------
LBL 28           ; Cubic: DROPs 3 elements, returns 3 roots
XEQ ".CUBIC"     ; Does error checking for stack depth and REAL elements
GTO 99           ; Back to the Run Loop
;----------------------------------------------------------------------------
LBL 29           ; Quartic: DROPs 4 elements, returns 4 roots
XEQ ".QRTC"      ; Does error checking for stack depth and REAL elements
GTO 99           ; Back to the Run Loop
;-----------------------------------------------------------------------
LBL ".QRTC" (4STK and NSTK compliant, also calls .CUBIC and .QUAD)
; Solves X^4 + aX^3 + bX^2 + cX + d   via   a ↑ b ↑ c ↑ d XEQ ".QRTC" 
; Drops the stack 4 levels and then pushes the 3 roots onto the stack
; Roots are stored in ".√4" → ".√1" (which can hold complex numbers)
; Coefficients are stored in ".X^3" → ".X^0"
;   This enables checking coefficients that would otherwise be lost and
;   subsequently using the SOLV menu button to repeat the calculation.
; A useful website: https://www.1728.org/quartic2.htm
; Some examples:
; X^4 -10X^3 +35X^2 -50X +24 = 0  (-10, 35, -50, 24)
;    Roots: 1, 2, 3, 4
; X^4 -9X^3 +45X^2 -87X +50 = 0   (-9, 45, -87, 50)
;    Roots: 1, 2, 3±i4
; X^4 -8X^3 +42X^2 -80X +125 = 0  (-8, 42, -80, 125)
;    Roots: 1±i2, 3±i4
; X^4 = 0                         (0, 0, 0, 0)
;    Roots: 0, 0, 0, 0
; X^4 -4X^3 +6X^2 -4X +1 = 0      (-4, 6, -4, 1)
;    Roots: 1, 1, 1, 1
; X^4 -2X^2 +1 = 0                (0, -2, 0, 1)
;    Roots: 1, 1, -1, -1
; X^4 +2X^2 +1 = 0                (0, 2, 0, 1)
;    Roots: i, i, -i, -i
;-----------------------------------------------------------------------
FUNC 44
; You get an NSTK error if you try to call this with too few arguments!
; RTNERR restores the original stack
REAL?            ; Testing X^0          X→T: d, c, b, a
SKIP
RTNERR 4         ; X^0: Invalid Type           
X<>Y
REAL?            ; Testing X^1          X→T: c, d, b, a
SKIP
RTNERR 4         ; X^1: Invalid Type           
X<> ST Z
REAL?            ; Testing X^2          X→T: b, d, c, a
SKIP
RTNERR 4         ; X^2: Invalid Type           
X<> ST T
REAL?            ; Testing X^3          X→T: a, d, c, b
SKIP
RTNERR 4         ; X^3: Invalid Type           
                 ; End of error checking
STO ".X^3"
X<> ST T         ;  X→T: b, d, c, a
STO ".X^2"
X<> ST Z         ;  X→T: c, d, b, a
STO ".X^1"
X<>Y             ;  X→T: d, c, b, a
STO ".X^0"
CLX
1                ; Set ".X^4"=1 to define a quartic is being solved
STO ".X^4"
CLX
RCL ".X^0"
LSTO ".plyq"     ; So ".QUAD"/".CUBIC" know ".QRTC" did initialization
                 ; End of coefficient storage, stack restored
;-----------------------------------------------------------------------
LSTO "d"         ; d  Avoid using R↑ and R↓ for NSTK compatibility
X<>Y
LSTO "c"         ; c  ONLY holds this value and only useful in .QRTC
X<> ST Z
LSTO "b"         ; b
X<> ST T
LSTO "a"         ; a  - Stack (X→T) is a, d, c, b
X^2
*                ; Stack (X→T) is  da^2, c, b
X<>Y
X^2
+                ; Stack (X→T) is  da^2+c^2, b
X<>Y
4
RCL* "d"
LSTO "d"         ; It's a hack, but "d" now holds 4d
*
-
1
X<>Y
RCL "b"          ; this is the last place "b" is used
X<>Y
RCL "a"
RCL* "c"
RCL- "d"
X<>Y
XEQ ".CUBIC"     ; Call ≈CUBIC (only once). Flag 6 set if a root was complex
X^2              ; sets LASTx_1 for next QUAD call 
RCL "d"          ; 4d from original .QRTC coefficient 
X<Y? 
GTO a
RCL ST T         ; ".√1"
CPX?
GTO a
X^2              ; sets LASTx_2 for next QUAD call
X>Y?
GTO a
RCL ST T         ; ".√2"
STO ST L         ; sets LASTx_3 for next QUAD call
LBL a            ; Doesn't care about the stack - only LASTx
1                ; Form a quadratic coefficient set that only depends on LASTX 
LASTX
CHS
RCL "d"          ; 4d from original .QRTC coefficient 
4
/
XEQ ".QUAD"      ; 1st call to QUAD (MUST return only real roots!)
                 ; doesn't need anything from the previous stack moving forward
CPX?
RTNERR 7         ; Shouldn't happen - remaining QUAD calls must have REAL coefficients!
; Form coefficients for 2 subsequent quadratic equations with coefficients:
; 2nd QUAD: .√2-.√1, -(a*.√1+c), .√1*(.√1-.√2)
; 3rd QUAD: .√2-.√1,  (a*.√2+c), .√2*(.√1-.√2)
X≠Y?             ; Filter .√2=.√1 yielding invalid quadratics (x^2 coeff will be zero)
GTO a
0≠? "a"
GTO b
0≠? "c"
GTO b
; a=0 & c=0 i.e. the quartic is of the form X^4 + bX^2 + d = 0 so solve that quadratic
1
RCL "b"
RCL "d"          ; 4d from original .QRTC coefficient 
4
/
XEQ ".QUAD"      ; x = ±√(.√1) and ±√(.√2)
SQRT
STO ".√2"
STO ST Z
+/-
STO ".√4"
X<>Y
SQRT
STO ".√1"
STO ST T
+/-
STO ".√3"
X<>Y
LCLV ".plyq"     ; Clear the POLY initialization variable
RTN
LBL b
; The quartic X^4 + aX^3 + bX^2 + cX + d is of the form (x^2 + ex + f)^2
; Expanding and equating coefficients yields:  2e = a  &  2ef = c
1
RCL "a"
2
/
RCL "c"
RCL "a"
/
XEQ ".QUAD"
STO ST Z
STO ".√4"
X<>Y
STO ST T
STO ".√3"
X<>Y
LCLV ".plyq"     ; Clear the POLY initialization variable
RTN
LBL a            ; 2 valid quadratics exist
STO ".√3"        ; temporary saving of ".√2" for 2nd QUAD
X<>Y
-
STO ".√4"        ; temporary saving of ".√2"-".√1" for 2nd QUAD
LASTX            ; ".√1"
RCL* "a"
RCL+ "c"
+/-
RCL ".√1"
RCL* ST Z
+/-
XEQ ".QUAD"      ; 2nd QUAD call - save roots in .√4 & .√3, recall 1st .√2 & .√1
X<> ".√4"        ; Save root to .√4 and get ".√2"-".√1" from 1st QUAD
X<>Y
X<> ".√3"        ; Save root to .√3 and get 1st QUAD .√2 root
ENTER
RCL* "a"
RCL+ "c"
X<>Y
RCL* ST Z
+/-
XEQ ".QUAD"      ; 3rd and final call to QUAD - roots stored in .√2 & .√1
RCL ".√3"
RCL ".√4"        ; Stack contains all 4 roots
LCLV ".plyq"     ; Clear the ".QRTC" initialization variable
RTN

;-----------------------------------------------------------------------
LBL ".CUBIC" (4STK and NSTK compliant, also calls .QUAD)
; Solves aX^3 + bX^2 + cX + d   via   a ↑ b ↑ c ↑ d  XEQ ".CUBIC"
; Returns with the guaranteed real root in X and the other two in Y & Z
; Drops the stack 4 levels and then pushes the 3 roots onto the stack
; Roots are stored in ".√3" → ".√1" (which can hold complex numbers)
; Guaranteed REAL root → X=".√3" and the others → Y=".√2" & Z=".√1". 
; Coefficients are stored in ".X^3" → ".X^0"
;   This enables checking coefficients that would otherwise be lost and
;   subsequently using the SOLV menu button to repeat the calculation.
; A useful website: https://www.1728.org/cubic2.htm
; Some examples:
;  2x^3 -12x^2 +22x -12 = 0    (2, -12, 22, -12)
;    Roots: 1, 2, 3
; -2X^3 +10X^2 -22X +30 = 0    (-2, 10, -22, 30)
;    Roots: 1±i2, 3
;-----------------------------------------------------------------------
; You get an NSTK error if you try to call this with too few arguments!
; RTNERR restores the original stack
FUNC 43          ; Stack (X→T) is d, c, b, a
XEQ e            ; TEST if ".QRTC" or ".CUBIC" has already done initialization
GTO c            ; Initialization already done by ".CUBIC" or ".QRTC"
REAL?            ; Testing X^0          X→T: d, c, b, a
SKIP
RTNERR 4         ; X^0: Invalid Type           
X<>Y
REAL?            ; Testing X^1          X→T: c, d, b, a
SKIP
RTNERR 4         ; X^1: Invalid Type           
X<> ST Z
REAL?            ; Testing X^2          X→T: b, d, c, a
SKIP
RTNERR 4         ; X^2: Invalid Type           
X<> ST T
REAL?            ; Testing X^3          X→T: a, d, c, b
SKIP
RTNERR 4         ; X^3: Invalid Type           
                 ; End of error checking
STO ".X^3"
X<> ST T         ;  X→T: b, d, c, a
STO ".X^2"
X<> ST Z         ;  X→T: c, d, b, a
STO ".X^1"
X<>Y             ;  X→T: d, c, b, a
STO ".X^0"
CLX              ; Reset variables not pertaining to a cubic solution
0                ; It's an NSTK thing...
STO ".X^4"
STO ".√4"
CLX
RCL ".X^0"
LSTO ".plyc"     ; Let ".QUAD" know ".CUBIC" did the initialization
                 ; End of coefficient storage, stack restored
;-----------------------------------------------------------------------
LBL c            ; Entry point if variable initialization & storage already done
RCL ST T         ; Avoiding R↑ for NSTK compatibility 
ST/ T
ST/ Z
/
2
/                ; d/2a
X<>Y
LSTO "c/a"       ; c/a
RCL ST Z
LSTO "b/a"       ; b/a
3
ST/ Z
/
LSTO "b/3a"      ; Stack (X→T) is b/3a, c/3a, d/2a, d/2a
X^2
-
RCL "c/a"        ; Stack (X→T) is c/a, c/3a - (b/3a)^2, d/2a, d/2a
2
ST/ Y            ; done to preserve LASTX
CLX
LASTX            ; Stack (X→T) is (b/3a)^2, c/2a, [c/3a - (b/3a)^2], d/2a
-
RCL* "b/3a"      ; Stack (X→T) is (c/2a-(b/3a)^2)*b/3a, [c/3a - (b/3a)^2], d/2a, d/2a
RCL ST Z         ; Used to access d/2a. Look for NSTK incompatibility with this command
-
STO ST Z         ; Stack (X→T) is [(c/2a-(b/3a)^2)*b/3a-d/2a], [c/3a-(b/3a)^2], [(c/2a-(b/3a)^2)*b/3a-d/2a], d/2a
X^2
X<>Y
3
Y^X
+                ; Stack (X→T) is [c/3a-(b/3a)^2]^3 + [(c/2a-(b/3a)^2)*b/3a-d/2a]^2, [(c/2a-(b/3a)^2)*b/3a-d/2a], d/2a, d/2a
; In 4STK mode Y→T are the same, but in NSTK mode Z→T are different!
; What follows must only rely on X & Y  
X<0?             ; This is a determinant - used to find the guaranteed real root
GTO a
SQRT             ; Determinant is positive. This section does 3√(Y+√X) & 3√(Y-√X) returning real numbers only
RCL+ ST Y        ; Some stack juggling to make NSTK work 
X<>Y
RCL- ST L
SIGN
LASTX 
ABS
3
1/X
Y^X
*
X<>Y
SIGN
LASTX
ABS
3
1/X
Y^X
*                ; only X & Y have useful information at this point 
GTO b
LBL a            ; Negative determinant. Returns Real(3√(√|X|+iY)) in both X & Y
CHS
SQRT
X<>Y
R-P
3
ST/ Z
1/X
Y^X
P-R
ENTER
LBL b            ; Determinant polarity issue resolved
+
RCL- "b/3a"      ; b/3a  After this the contents of the stack are inconsequential
STO ".√3"        ; This is the guaranteed real CUBIC root. Now set up the quadratic
1
RCL "b/a"        ; b/a
RCL+ ST Z
ENTER
RCL* ST T
RCL+ "c/a"
XEQ ".QUAD"      ; Stack (X→T) is (".√3"+b/a)*".√3"+c/a, ".√3"+b/a, 1, x
RCL ".√3"
LCLV ".plyc"     ; Clear the ".CUBIC" initialization variable
RTN

;-----------------------------------------------------------------------
LBL ".QUAD" (4STK and NSTK compliant)
; Solves aX^2 + bX + c   via   a ↑ b ↑ c XEQ ".QUAD"
; Drops the stack 3 levels and then pushes the 2 roots onto the stack
; Roots are stored in ".√2" → ".√1" (which can hold complex numbers)
; Coefficients are stored in ".X^2" → ".X^0" with ".X^3"=0 
;   This enables checking coefficients that would otherwise be lost and
;   subsequently using the SOLV menu button to repeat the calculation.
; Some examples:
;  2x^2 -6x +4 = 0     (2, -6, 4)
;    Roots: 1, 2
; -2X^2 +4X -10 = 0    (-2, 4, -10)
;    Roots: 1±i2
;-----------------------------------------------------------------------
FUNC 32          ; Even without this, the T register isn't destroyed 
; You get an NSTK error if you try to call this with too few arguments!
; RTNERR restores the original stack
XEQ e            ; TEST if ".QRTC"/".CUBIC" has already done initialization
GTO c            ; Initialization already done by ".CUBIC" or ".QRTC"
REAL?            ; Testing X^0          X→T: c, b, a, ?
SKIP
RTNERR 4         ; X^0: Invalid Type           
X<>Y
REAL?            ; Testing X^1          X→T: b, c, a, ?
SKIP
RTNERR 4         ; X^1: Invalid Type           
X<> ST Z
REAL?            ; Testing X^2          X→T: a, c, b, ?
SKIP
RTNERR 4         ; X^2: Invalid Type           
X=0? 
RTNERR 5         ; X^2: Invalid Data           
                 ; End of error checking
0                ; Reset variables not pertaining to a quadratic solution
STO ".X^4"
STO ".X^3"
STO ".√4"
STO ".√3"
DROP             ;  X→T: a, c, b, ?
STO ".X^2"
X<> ST Z         ;  X→T: b, c, a, ?
STO ".X^1"
X<>Y             ;  X→T: c, b, a, ?
STO ".X^0"
                 ; End of coefficient storage, stack restored
;-----------------------------------------------------------------------
LBL c            ; Entry point if variable initialization & storage already done
X<> ST Z
STO/ ST Z
STO+ ST X
/
+/-
X^2
LASTX
X<> Z
-                ; X = (-b/2a)^2 - c/a, Y = -b/2a
SQRT             ; can be complex
ENTER
+/-
X<> ST Z
STO+ ST Z
+                ; The solve is complete, now just store the results
STO ".√1"        ; 1st root (-b + √determinant)/2a
X<>Y
STO ".√2"        ; 2nd root (-b - √determinant)/2a
RTN
;-----------------------------------------------------------------------
LBL e            ; A CONDITIONAL to see if initialization has already been done
FUNC 00
SF 25
RCL ".plyq"      ; A variable who's existence says ".QRTC" did the initialization 
FS?C 25
RTNYES           ; INIT has already been done
SF 25
RCL ".plyc"      ; A variable who's existence says ".CUBIC" did the initialization 
FS?C 25
RTNYES           ; INIT has already been done
RTNNO            ; INIT needs to be done

;------------------------------------------------------------------------
; 2026.1010: TVM - Mick Mueck mick.mueck@mac.com
;------------------------------------------------------------------------
; With thanks to Thomas Okken's open source TVM code and Duncan Murray
; Requires at least Free42 version 3.4
; Don't even try to modify this code without reaching out to me first - it's
; too complex! I have a copy with tons more comments you'll want to have. 

; Mimics Plus42's TVM with the exception of AMRT (Amortization)
; This code will run both in 4STK and NSTK modes.
; Uses LBLs unused by .CONST & .POLY: A→J,47→49,57→59,67→69,77→79,87→95

; Terminology:
; N:    Number of Periods
; I%YR: Interest % per Year   ("I%YR"=i*100*"P/YR")
; PV:   Present Value 
; PMT:  Payment
; FV:   Future Value
; P/YR: Payments/Year (input only)

; •The "big-5" primary TVM variables are N, I%YR, PV, PMT, FV
; •They are internally stored in global registers of the same name.
; •They are entered and solved for in classic HP42S VARMENU style i.e. the
;    known variables are stored by doing num1→menu1, num2→menu2 etc. and a
;    successive click on an unknown variable's button i.e. num4→menu4→menu5
;    changes the data entry mode from STORE to SOLVE. I never liked VARMENU's 
;    behavior because if you want to store the same number into two different
;    variables the second variable's menu button press initiates SOLVE instead
;    of STORE. Also, if you leave the calculator for a while and come back to 
;    it later you might not remember which state you left it in.
; •CLEAR zeros all 5 primary TVM variables and sets the data entry mode to STO.
; •RESET performs:  P/YR = 12  and  BEGIN = 0 (i.e. END mode)
; •P/YR (Payments/Year) is write-only and must be an integer between 1 → 999.
; •BEGIN, END set the payment to the beginning or end of the payment period.
; •RESET, BEGIN, END & P/YR do NOT alter your data entry mode.
; •STO shows the current data entry mode and toggles it when pressed.
; •When you start TVM, no previous TVM state is lost, but you are put into 
;    STORE data entry mode for your next TVM variable button click.
; •⇧Press on any of the big-5 buttons to briefly reveal it's value.
; •You can also do RCL (or STO or VIEW) and select a variable from that menu.
; •The big-5 menu buttons show helpful hints by interpreting their variables
;    after each menu button press. A zero value is denoted by a trailing "." 
;    and an illegal value by a trailing "!". You can't enter an illegal value
;    via the menus, but you can externally write one directly into its variable.
; •TVM can be used by other programs. Write to known TVM registers and also to 
;    the BEGIN variable (which can ONLY be 0 or 1) and then XEQ the variable
;    name to be solved. Ordinarily all my skin related program and variable  
;    names start with ".", but for Plus42 TVM compatibility these ones do not.

LBL "TVM"
XEQ e            ; Initialization
; Each big-5 menu routine should SF 33 to mimic VARMENU behavior.
;------------------------------------------------------------------------
LBL A            ; MAIN RUN LOOP (ONLY modifies the Alpha-register)
;------------------------------------------------------------------------
XEQ D            ; Make the RCL menu match the big-5 in the TVM menu.
CLMENU
0>? ".tvml"      ; Build the currently selected menu level
GTO a
"N"
XEQ c            ; Badge menu label with "." if zero, "!" if illegal
KEY 1 GTO 47     ; "N"
"I%YR"
XEQ c            ; Badge menu label with "." if zero, "!" if illegal
KEY 2 GTO 48     ; "I%YR"
"PV"
XEQ c            ; Badge menu label with "." if zero, "!" if illegal
KEY 3 GTO 49     ; "PV"
"PMT"
XEQ c            ; Badge menu label with "." if zero, "!" if illegal
KEY 4 GTO 57     ; "PMT"
"FV"
XEQ c            ; Badge menu label with "." if zero, "!" if illegal
KEY 5 GTO 58     ; "FV"
"CLEAR"
KEY 6 GTO 59     ; "CLEAR"
GTO b

LBL a            ; Create the 2nd Level menu
XEQ d            ; P/YR: Badge menu label with "." if zero, "!" if illegal
KEY 1 GTO 67     ; "P/YR"
"BEGIN"
0≠? "BEGIN"
"BEGI•"
KEY 2 GTO 68     ; "BEGIN"/BEGI•"
"END"
0=? "BEGIN"
├"•"
KEY 3 GTO 69     ; "END"/END•"
CLA
KEY 4 GTO A      ; NOP
"STO"
FC? 33
├"•"
KEY 5 GTO 77     ; STO/XEQ mode toggle for the next big-5 menu operation
"RESET"
KEY 6 GTO 78     ; "RESET"
LBL b
KEY 7 GTO 87     ; Menu UP
KEY 8 GTO 87     ; Menu DOWN
KEY 9 GTO 88     ; EXIT
CLA
ARCL ".tvma"     ; Restore the Alpha-register
MENU1
STOP             ; Menu functions start their XEQs from this location
GTO A            ; Ideally this never gets executed due to KEYG usage
;------------------------------------------------------------------------
LBL 87           ; Invert the menu level
XEQ a            ; FUNC 00 will protect the stack & LASTX
GTO A            ; Back to the Run Loop
LBL a
FUNC 00
-1
STO* ".tvml"
0>? ".tvml"      ; menu level 2?
XEQ B            ; Yes, show the status line
RTN              ; Maintain exist data entry mode
;------------------------------------------------------------------------
LBL 88           ; EXIT - restore affected original environment
CLA
ARCL ".tvma"     ; Restore the Alpha-register
CLV ".tvml"      ; Remove TVM internal variables
CLV ".tvma"
CLV ".tvmv"
CLMENU           ; From page 148 of the HP42S manual
EXITALL
;RTN             ; If execution stopped at some random place due to an
                 ; error, this will RTN there and likely yield an error.
STOP             ; May leave debris on the stack, but better than RTN
;------------------------------------------------------------------------
LBL c            ; Make MENU hints "!" or "." for N, I%YR, PV, PMT, FV
FUNC 00
XASTO ST X
RCL IND ST X     ; Guaranteed to exist due to XEQ D
REAL?
GTO a
├" !"
RTN
LBL a
X=0?
├"."
RTN

LBL d            ; Make MENU hints "!" or "." ONLY for P/YR
FUNC 00
"P/YR"
RCL "P/YR"
XEQ J
SKIP
RTN
CLA
"P/YR!"          ; P/YR was illegal 
RTN
;------------------------------------------------------------------------
LBL e            ; TVM INITIALIZATION (modifies X, so use FUNC 00)
FUNC 00
CF 33            ; For STO operation on the big 5 (to mimic VARMENU)
XASTO ".tvma"    ; Save the Alpha-register
1
STO ".tvml"      ; Set the TVM menu level
RTN
;------------------------------------------------------------------------
LBL D            ; Clear & recreate N I%YR PV PMT FV P/YR MODE in reverse
;                  order so the RCL menu matches TVM's. Sets them to the 
;                  default if since returning to TVM they were cleared.
;                  If MODE is illegal (i.e. not 0 or 1) it is set to 0.
FUNC 00
0                ; Default value
CF 25            ; Just in case some rogue function didn't clear it
XSTR "BEGIN"
XEQ a
REAL?            ; Only MODE is constantly forced to be legal
SKIP
0
X≠0?
1
STO "BEGIN"
12               ; Default value
XSTR "P/YR"
XEQ a
0                ; Default value
XSTR "FV"
XEQ a
0                ; Default value
XSTR "PMT"
XEQ a
0                ; Default value
XSTR "PV"
XEQ a
0                ; Default value
XSTR "I%YR"
XEQ a
0                ; Default value
XSTR "N"
XEQ a
CLV ".tvmv"      ; to reduce clutter between menu commands
RTN
; CLEAR & RECREATE the variable in X. Default value in Y.
LBL a
SF 25
RCL IND ST X     ; Make sure it exists
FC?C 25
RCL ST Y         ; default value, Y holds the variable name
CLV IND ST Y
STO IND ST Y
RTN
;------------------------------------------------------------------------
LBL 47           ; N
"N"
XEQ C
GTO A            ; Back to the Run Loop
;------------------------------------------------------------------------
LBL 48           ; I%YR
"I%YR"
XEQ C
GTO A            ; Back to the Run Loop
;------------------------------------------------------------------------
LBL 49           ; PV
"PV"
XEQ C
GTO A            ; Back to the Run Loop
;------------------------------------------------------------------------
LBL 57           ; PMT
"PMT"
XEQ C
GTO A            ; Back to the Run Loop
;------------------------------------------------------------------------
LBL 58           ; FV
"FV"
XEQ C
GTO A            ; Back to the Run Loop
;------------------------------------------------------------------------
LBL 59           ; CLEAR
XEQ a            ; FUNC 00 will protect the stack & LASTX
GTO A            ; Back to the Run Loop
LBL a
FUNC 00
0
STO "FV" 
STO "PMT"
STO "PV"
STO "I%YR"
STO "N"
CF 33            ; After a CLEAR, setup the big-5 menu for STO
RTN              ; Back to the Run Loop
;------------------------------------------------------------------------
LBL 67           ; P/YR
"P/YR"
SF 25
LSTO "X"         ; Pass X into a FUNC 00 without disturbing LASTX 
FC?C 25
GTO b            ; "Nonexistent" error message, and GTO A
XEQ a
GTO A            ; Back to Run Loop, data entry mode Flag 33 untouched
LBL b
├": Nonexistent"
AVIEW
CF 33            ; Setup big-5 menus for STO after an error
GTO A            ; Back to the Run Loop

LBL a
FUNC 00          ; Now preserve the stack and LASTX
RCL "X"
ASTO ".tvmv"     ; Store the variable name into ".tvmv"
FS? 64           ; See if shift was pressed
GTO G            ; Yes, VIEW "P/YR" for 1 sec if it exists
XEQ J            ; Conditional XEQ: Error check X for P/YR constraints
GTO 90           ; P/YR was illegal, VIEW the error message.
STO "P/YR"       ; P/YR was good 
XEQ B            ; Display the Status Line
RTN

; Must be called from a FUNC 00 world because it mangles the stack
LBL J            ; CONDITIONAL Function. P/YR INTEGER & Range check 
REAL?
SKIP
GTO a
FP
1000             ; Max P/YR to match Plus42
1
LASTX            ; "P/YR", 1, 1000, FP("P/YR")
0≠? ST T
GTO a            ; Invalid Type ("P/YR" not an INTEGER)
X<? ST Y
GTO b            ; Invalid data ("P/YR"<1)
X≥? ST Z
GTO b            ; Invalid data ("P/YR"≥1000)
RTNNO            ; P/YR variable is good.
LBL a
├": Invalid"
RTNYES           ; Variable is bad
LBL b
├": Range Error"
RTNYES           ; Variable is bad
;------------------------------------------------------------------------
LBL 68           ; BEGIN
XEQ a            ; FUNC will protect the stack & LASTX
GTO A            ; Back to the Run Loop
LBL a
FUNC 00
1
STO "BEGIN"
GTO B            ; Display the Status Line and RTN
;------------------------------------------------------------------------
LBL 69           ; END
XEQ a            ; FUNC will protect the stack & LASTX
GTO A            ; Back to the Run Loop
LBL a
FUNC 00
0
STO "BEGIN"
GTO B            ; Display the Status Line and RTN
;------------------------------------------------------------------------
LBL 77           ; STO/XEQ mode toggle for the next menu operation
FC?C 33          ; Toggle flag 33 (SET→XEQ, CLEAR→STO)
SF 33
GTO A            ; Back to the Run Loop
;------------------------------------------------------------------------
LBL 78           ; RESET
XEQ a            ; FUNC will protect the stack & LASTX
GTO A            ; Back to the Run Loop
LBL a
FUNC 00
12
STO "P/YR"
0
STO "BEGIN"
;------------------------------------------------------------------------
LBL B            ; TVM status line. Come here from a FUNC 00 place.
SF 25
RCL "P/YR"       ; In case P/YR was not set if TVM called externally
FC?C 25
12
STO "P/YR"
"???"            ; The default if P/YR is not real
REAL?
CLA
REAL?
AIP              ; append integer part to the alpha register
SF 25
RCL "BEGIN"      ; In case BEGIN was not set if TVM called externally 
FC?C 25
0
STO "BEGIN"
├" P/YR"
0=? "BEGIN"
XSTR "                      END Mode"  ; This string length is 30
0≠? "BEGIN"
XSTR "                    BEGIN Mode"  ; This string length is 30
ALENG
WIDTH            ; (WIDTH+1)/6 → number of columns in Plus42/Free42 
1                ; Plus42's "GETDS" is not a valid Free42 instruction 
+
6
÷
-                ; Negative number indicates SUBSTR is right justified 
SUBSTR
ARCL ST X        ; Right justify the MODE on the status line
AVIEW
RTN
;------------------------------------------------------------------------
LBL C            ; STO, VIEW or SOLVE  N, I%YR, PV, PMT, FV
;                  This routine does NOT modify the stack or LASTx 
ASTO ".tvmv"     ; Store the variable name into ".tvmv"
FS? 64           ; See if shift was pressed
GTO G            ; Yes, VIEW the variable for 1 sec if it exists
FS? 33           ; No,  Is this a sequential menu button press?  
GTO F            ; Yes, Solve for the variable
SF 33            ; Keep the menu behaving like VARMENU
SF 25            ; Check for trying a STO with an empty NSTK
STO ST X
FC?C 25
GTO b            ; Trying to STO an empty X-register :-/
REAL?            ; Validate REAL or confirm X isn't blank in NSTK
SKIP
GTO a            ; Trying to STO a number that isn't REAL
STO IND ".tvmv"  ; Store the error checked variable
├"="             ; "=" signifies a STO operation 
ARCL ST X
GTO c            ; VIEW the Alpha-register for 1 sec

LBL F            ; XEQ the program implied by the variable
XEQ IND ".tvmv"  ; RTNERR: Execution stops here with an error message
                 ; or X=answer without having touched the Alpha-register 
├"→"             ; "→" signifies the result of a calculation
ARCL ST X
GTO c            ; Show the Alpha-register for 1 second

; VIEW results 
LBL G            ; ⇧MENU: VIEW the variable for 1 sec if it exists 
XEQ d            ; Existence check
GTO b            ; Variable doesn't exist
├":"             ; ":" signifies a VIEW operation
ARCL IND ".tvmv"
LBL c            ; Show the Alpha-register for 1 second
AVIEW
SF 33            ; Allows big-5 XEQ during a PSE
PSE
CLD
RTN
LBL a
├": Not REAL"
GTO 90           ; View an error message that you need to dismiss
LBL b
├": Nonexistent"
LBL 90           ; View an error message that you need to dismiss
CF 33            ; Set STO data entry mode after an error
AVIEW
RTN

LBL d            ; Existence test for variable in the Alpha-register
FUNC 00
ASTO ST X        ; Store the variable name into X
SF 25
RCL IND ST X 
FC?C 25
RTNYES           ; Does not exist
RTNNO            ; Does exist
;------------------------------------------------------------------------
LBL "N"          ; Solve for N (for i=0 & i≠0)
FUNC 01
2                ; Error check all variables except N
XEQ E            ; A CONDITIONAL XEQ
GTO H            ; Variable error checking failed
XEQ I            ; creates "i" from I%YR & PMT(mode)
RCL "PV"
RCL+ "FV"        ; PV+FV, i, pmt  L=PV
0≠? ST Y         ; i≠0?
GTO a
0=? ST Z         ; pmt=0?
GTO b            ; ERROR: pmt=0, Invalid Data 
RCL÷ ST Z
+/-
STO "N"
RTN              ; Return with the result stored in "N"
LBL a            ; Calculate -log1p((PV+FV)/((pmt/i)-FV)) / log1p(i)
RCL ST Z         ; pmt, PV+FV, i, pmt
RCL÷ ST Z
RCL- "FV"
÷
LN1+X
+/-              ; -log1p((PV+FV)/((pmt/i)-FV)), i, pmt
X<>Y
LN1+X
÷
STO "N"
RTN              ; Return with the result stored in "N"
LBL b
CLA
"ERROR: PMT=0"
GTO H

;------------------------------------------------------------------------
LBL "PV"         ; Solve for PV (for i=0 & i≠0)
FUNC 01
4                ; Error check all variables except PV
XEQ E            ; A CONDITIONAL XEQ
GTO H            ; An error was detected
RCL "FV"
XEQ I            ; creates "i" from I%YR
RCL "N"
+/-              ; -N, i, pmt, FV
0=? ST Y         ; 0=? i
GTO a            ; Calculate PV(i=0)   -(FV+PMT*N)
X<>Y             ; Calculate expm1(-n*log1p(i))*pmt/i - fv*exp(-n*log1p(i)))
STO÷ ST Z        ; i, -N, pmt/i, FV
LN1+X
×                ; -N*log1p(i), pmt/i, FV
E↑X
STO× ST Z
LASTX            ; -N*log1p(i), exp(-n*log1p(i))), pmt/i, fv*exp(-n*log1p(i)))
E↑X-1
LBL a
RCL× ST Z        ; expm1(-n*log1p(i))*pmt/i, exp(-n*log1p(i))), pmt/i, fv*exp(-n*log1p(i)))
RCL- ST T
STO "PV"
RTN              ; Return with the result stored in "PV"

;------------------------------------------------------------------------
LBL "FV"         ; Solve for FV (for i=0 & i≠0)
FUNC 01
6                ; Error check all variables except FV
XEQ E            ; A CONDITIONAL XEQ
GTO H            ; An error was detected
RCL "PV"
XEQ I            ; creates "i" from I%YR
RCL "N"
+/-              ; -N, i, pmt, PV
0=? ST Y         ; 0=? i
GTO a            ; Calculate FV(i=0)   -(PV+PMT*N)
X<>Y             ; Calculate FV(i≠0)  (pmt/i*expm1(-n*log1p(i))-PV)/exp(-n*log1p(i)) 
STO÷ ST Z        ; i, -N, pmt/i, PV
LN1+X
×                ; -N*log1p(i), pmt/i, PV
E↑X
LASTX            ; -N*log1p(i), exp(-n*log1p(i)), pmt/i, PV
E↑X-1
LBL a
RCL× ST Z
RCL- ST T
RCL÷ ST Y
STO "FV"
RTN              ; Return with the result stored in "FV"

;------------------------------------------------------------------------
LBL "PMT"        ; Solve for PMT (for i=0 & i≠0)
FUNC 01
5                ; Error check all variables except PMT
XEQ E            ; A CONDITIONAL XEQ
GTO H            ; An error was detected
XEQ I            ; creates "i" from I%YR
RCL "FV"
RCL "PV"
+
RCL "N"          ; N, PV+FV, i, pmt
X=0?
GTO c            ; ERROR: N=0, Invalid Data 
0=? ST Z         ; 0=? i
GTO a            ; Calculate PMT(i=0)   -(PV+FV)/N
RCL ST Z         ; Calculate -((pv+fv)/expm1(n*log1p(i)) + pv)*i
LN1+X            ; log1p(i), N, PV+FV, i
×
E↑X-1            ; expm1(N*log1p(i)), PV+FV, i, N
÷
RCL+ "PV"
RCL× ST Y
+/-              ; -((pv+fv)/expm1(n*log1p(i)) + pv)*i, i, N
X<>Y             ; Now do  if (mode == 1) pmt /= 1+i
RCL× "BEGIN"
1
+
÷
STO "PMT"
RTN              ; Return with the result stored in "PMT"
LBL a            ; PMT(i=0) = -(PV+FV)/N
÷
+/-
STO "PMT"
RTN              ; Return with the result stored in "PMT"
LBL c
CLA
"ERROR: N=0"
GTO H

;------------------------------------------------------------------------
LBL I            ; Calculates i = "I%YR"/100/"P/YR" Called by PMT, PV, FV, N
;                  Can't do any LSTOs here because they vanish upon RTN
;                  Returns X=i, Y=PMT(mode) - that hidden in Thomas's tvm_arg_chk code!
;                  The calling Y-register will not survive in 4STK 
0.01
RCL× "I%YR"
RCL÷ "P/YR"      ; i = "I%YR"/100/"P/YR"
DUP              ; pmt = PMT*(1+M*i) Use this when calculating N, PV & FV
RCL× "BEGIN"
1
+
RCL× "PMT"
X<>Y
RTN

;------------------------------------------------------------------------
LBL "I%YR"       ;  (for Begin_mode & End_mode) Returns I%YR in X
FUNC 01
; Need to do argument checking
; i: interest factor per payment period e.g. 0.01/month.
; I%YR: %interest/yr e.g. i*100*"P/YR" 

3                ; Error check all variables except I%YR
XEQ E            ; A CONDITIONAL XEQ
GTO H            ; An error was detected
0=? "N"
GTO 91           ; ERROR: N=0 
RCL "FV"
RCL "PV"
0≠? "PMT"
GTO a            ; pv, fv   Iterate to find i
×
X≥0?
GTO 91           ; ERROR: pv*fv ≥ 0 
RCL "FV"         ; i = expm1(log(-FV/PV)/n);
RCL÷ ST L
+/-
LN
RCL÷ "N"
E↑X-1
LSTO "i"
GTO 92           ; Finish up
LBL a            ; stack is PV, FV
RCL "PMT"        ; if (M==1) {pv += pmt; fv -= pmt;}
RCL× "BEGIN"
RCL+ ST Y        ; PV+PMT×m, PV, FV
LSTO "pv"        ; pv=PV+PMT×M
RCL ST Z
RCL- ST L
LSTO "fv"        ; fv=FV-PMT×M, pv
x
X≠0?
GTO a            ; pv & fv are non-zero
RCL "PMT"        ; one or both of fv & pv are zero
LASTX            ; fv, PMT
RCL- "pv"        ; fv-pv, PMT
X=0?
GTO 91           ; ERROR: pv=fv=0 
÷                ; fv=0 or pv=0, do i=PMT/(fv-pv)
LSTO "i"
GTO b            ; Error check "i" and proceed
LBL a            ; pv & fv are non-zero
-1
LSTO "i"         ; default "i" (will → 0 if used)
RCL "PMT"
RCL÷ "pv" 
+/-              ; b=-PMT/pv, -1
ABS
LASTX            ; b, abs(b), -1
RCL "PMT"
RCL÷ "fv"        ; a=PMT/fv, b, abs(b), -1
LSTO "i"         ; default for now
ABS              ; abs(a), b, abs(b), -1
STO- ST Z
CLX
LASTX            ; a, b, abs(b)-abs(a), -1
0<? ST Z         ; This hurt my brain
X≤? ST T         ; a ≤ -1?
X<>Y             ; use b
LSTO "i"
LBL b            ; Error check i (assumes T=-1)
-1
RCL "i"
X≤Y?             ; i ≤ -1?
STO- "i"         ; yes: i=0
3                ; was 2, but use 3 and DSE command
LSTO "c"
0
LSTO "f"
LBL 93
RCL "f"
LSTO "f0"
1
RCL "i"
X↑2
RCL× "N"         ; N*i^2, 1, f0
RCL+ ST Y        ; 1+N*i^2, 1, f0
X≠? ST Y
GTO 94
CLX
RCL "pv"
RCL+ "fv"
RCL÷ "N"         ; a=(pv+fv)/N, 1, f0
DUP
RCL+ "PMT"
LSTO "f"         ; f, a, 1, f0 
RCL "N"
X↑2              ; N^2, f, a, 1
RCL- ST T
RCL× ST Z
RCL× "i"
6
÷                ; b=(n*n-1)*a/6*i, f, a
RCL "pv"
RCL- "fv"
RCL+ ST T        ; (pv-fv+a), b, f, a
-0.5
×
RCL- ST Y        ; -fp=-(pv-fv+a)/2-b, b, f
-0.5
RCL× ST Z        ; -b/2, -fp, b, f
RCL- ST Y
RCL× "i"
RCL+ ST T        ; f=f+(fp-b/2)*i, -fp, b, f(old)
LSTO "f"         ; this is used elsewhere 
RCL÷ ST Y
LSTO "eps"       ; eps=-f/fp
STO+ "i"
GTO 95
LBL 94           ; Stack: 1+N*i^2, 1, f
CLX
RCL "pv"
RCL+ "fv"        ; pv+fv, 1
RCL "i"
DUP              ; i, i, pv+fv, 1
LN1+X
RCL× "N"
E↑X-1
÷                ; x=i/expm1(n*log1p(i)), pv+fv, 1
STO× ST Y        ; x, k=(pv+fv)*x, 1
RCL+ "i"
RCL× "N"
RCL- ST Z        ; n(x+i)-1, k, 1
RCL "i"
STO- ST Y        ; i, num=n(x+i)-1-i, k, 1
RCL+ ST T
RCL× ST L        ; den=i(i+1), num, k, 1
÷                ; num/den, k, 1
RCL× ST Y
RCL "pv"
STO- ST Y        ; pv, k*num/den-pv, k,1
RCL× "i"
RCL+ "PMT"
RCL+ ST Z
; This eps formula contains 2 divides...
LSTO "f"         ; f=pv*i+pmt+k, k*num/den-pv, k, 1
X<>Y
÷
LSTO "eps"       ; eps=f/(k*num/den-pv)
STO+ "i"
LBL 95
DSE "c"          ; If you want to do 2 loops, set c=3
GTO 93
RCL "f"
X=0?
GTO 92           ; break out of the WHILE loop
RCL× "f0"
X≤0?
GTO 92           ; break out of the WHILE loop
LASTX            ; f
ABS
RCL "f0"
ABS
X>Y?
GTO 93           ; continue if |f0|>|f|
1E-6
RCL× "eps"
RCL+ "i"
X≠? "i"
GTO a            ; Error - No solution found
0.5
RCL× "eps"
STO- "i"

LBL 92           ; Finish WHILE loop (exit point) 
100              ; Convert i to I%YR
RCL× "i"
RCL× "P/YR"
STO "I%YR"
RTN              ; Return with the result stored in "I%YR"
LBL 91           ; ERROR - I%YR: Invalid arguments
CLA
"ERROR: Bad"
├" PV, FV or N"
GTO H            ; Error
LBL a            ; ERROR - No solution found 
CLA
"ERROR: "
├"No Solution"
LBL H            ; Common entry point to return all errors.
CF 33            ; Setup big-5 menus for STO after an error
XASTO ST X
CLA
RTNERR IND ST X

;------------------------------------------------------------------------
LBL E            ; Error checking. Must be called from a FUNC 00
;                  Index: 7→MODE, 6→FV, 5→PMT, 4→PV, 3→I%YR, 2→N, 1→P/YR
;                        >0 Check everything except the indexed variable
;                        ≥8 Error check everything
;                  NOTE: Uses RTNYES & RTNNO, so it behaves like a TEST!
;                  Errors: RTNYES with error message in Alpha-register
;                  Checks performed:
;                      MODE  Existence, 0 or 1
;                      FV    Existence, Real
;                      PMT   Existence, Real
;                      PV    Existence, Real
;                      I%YR  Existence, Real
;                      N     Existence, Real
;                      P/YR  Existence, Integer between 1 → 999

XEQ a            ; Create {"P/YR" "N" "I%YR" "PV" "PMT" "FV" "BEGIN"}
7
LBL 89           ; counter, arg_list, arg_skip
X=? ST Z         ; Skip this arg? 
DSE ST X         ; Won't skip because 2 ≤ Z ≤ 6. Doesn't change LASTx
GETLI ST Y       ; Get arg from the list based on the index in X
LSTO "arg"       ; arg_name, counter, arg_list, arg_skip
DROP             ; Check arg for existence and being REAL
SF 25            ; counter, arg_list, arg_skip
RCL IND "arg"
FC?C 25
GTO b            ; Invalid - Nonexistent
REAL?            ; arg_val, counter, arg_list, arg_skip
SKIP 
GTO b            ; Invalid Type (not a REAL number)
DROP             ; counter, arg_list, arg_skip
DSE ST X         ; arg exists and is real
GTO 89           ; counter, arg_list, arg_skip
RCL "P/YR"       ; At the end of the list, now check P/YR & MODE
FP
1000             ; Max P/YR to match Plus42
1
LASTX            ; "P/YR", 1, 1000, FP("P/YR")
0≠? ST T
GTO b            ; Invalid Type ("P/YR" not an INTEGER)
X<? ST Y
GTO b            ; Invalid data ("P/YR"<1)
X≥? ST Z
GTO b            ; Invalid data ("P/YR"≥1000)
XSTR "BEGIN"     ; Done checking P/YR, now check MODE for 0 or 1
LSTO "arg"
1
0≠? "BEGIN"      ; At the end, so check the mode register "BEGIN"
X=? "BEGIN"
RTNNO            ; All arguments good, skip the next instruction
LBL b            ; Error detected - illegal value or nonexistent
CLA
"ERROR: "
ARCL "arg"
├" is invalid"
RTNYES           ; Bad argument, display error message 

LBL a            ; Make the list - would have been easier with LNSTK,
FUNC 01          ; but requires Free42 users to enable Big Stack.
XSTR "P/YR"      ; 1st list element (index = 1)
XSTR "N"         ; 2nd list element (index = 2)
XSTR "I%YR"      ; 3rd list element (index = 3)
3                ; number of elements
→LIST            ; create the list
XSTR "PV"        ; 4th list element (index = 4)
APPEND
XSTR "PMT"       ; 5th list element (index = 5)
APPEND
XSTR "FV"        ; 6th list element (index = 6)
APPEND
XSTR "BEGIN"     ; 7th list element (index = 7)
APPEND
RTN
END