; 2026.1010 Mueck_p42.txt
; Program suite for all Mueck_p42 Plus42 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".

; Usage instructions for .CONST and .POLY 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
END