edp@jareth.enet.dec.com (Eric Postpischil (Always mount a scratch monkey.)) (03/05/91)
Here are routines CUBIC and QUARTIC which solve cubic and quartic equations,
similar to the way that the QUAD function solves quadratic equations. The
use for both is the same as QUAD:
'symbolic1' 'global' -> 'symbolic2'
These routines are also similar to QUAD in that they compute a Taylor's series
of the appropriate degree (courtesy of PCOEF, previously posted by William
C. Wickes) and honor the principal values flag (-1).
The solutions are the exact algebraic solutions, so they will find complex
roots and duplicate roots. The routines ABC and ABCD are for internal use but
might be usable anyway -- they take three or four coefficients, as in a, b, and
c of x^3+a*x^2+b*x+c or a, b, c, and d for the quartic, and return the solution
as an expression. If you enter A B C D ABCD, you will get an algebraic that
represents the general solution for quartic equations. It's 3,153 bytes and
takes thousands more to display. (I only had 10Kb free; that wasn't enough to
hold the algebraic and display it.)
The programs N1 and S12 will take the general solution of a cubic or quartic,
respectively, and substitute the three or four combinations of values for the
n1 or s1 and s2 variables, returning the general solution and the three or
four specific solutions to the stack.
-- edp (Eric Postpischil)
"Always mount a scratch monkey."
%%HP: T(3)A(D)F(.);
DIR
CUBIC
\<< \-> var \<<
EQ\-> - var 3 PCOEF LIST\-> DROP \-> a b c d \<<
var b a / c a / d a / PQR =
\>>
\>> \>>
QUARTIC
\<< \-> var \<<
EQ\-> - var 4 PCOEF LIST\-> DROP \-> a b c d e \<<
var b a / c a / d a / e a / ABCD =
\>>
\>> \>>
PQR
\<< \-> p q r \<<
q p SQ 3 / - 2 p 3 ^ * 9 p * q * - 27 / r + OVER -3 / \v/ 2 *
ABM p 3 / -
\>> \>>
ABM
\<< \-> a b m \<<
3 b * a m * / 'COS(ABM)' = 'ABM' ISOL EQ\-> SWAP DROP
{ 's1*&A' '&A' } \|^MATCH DROP 3 / COS m *
\>> \>>
ABCD
\<< RCLF \-> a b c d f \<<
b NEG a c * 4 d * - 4 b * d * a SQ d * - c SQ - -1 SF PQR f STOF
\-> y \<< y b - a SQ 4 / + \v/ \-> R \<<
3 a SQ * 4 / R SQ - 2 b * -
R 0 \=/
4 a * b * 8 c * - a 3 ^ - 4 R * /
y SQ 4 d * - \v/ 2 *
IFTE
DUP2 + \v/ 2 / 3 ROLLD - \v/ 2 /
\-> D E \<<
a -4 / R 2 / IF -1 FC? THEN 's1' * END +
IF -1 FC? THEN 's1>0' ELSE 1 END
D E IFTE
IF -1 FC? THEN 's2' * END +
\>>
\>> \>>
\>> \>>
PCOEF
\<<
3 DUPN TYPE SWAP TYPE ROT
TYPE 3 \->LIST { 0 6 9 }
IF ==
THEN DUP 1 + \-> n
\<< #18CEAh SYSEVAL
SWAP
#549CCh SYSEVAL
#74D0h SYSEVAL
#59373h SYSEVAL
DROP #7497h SYSEVAL
1 n
FOR m m ROLL COLCT
NEXT
n \->LIST
\>>
END
\>>
N1
\<<
DUP { n1 0 } | OVER { n1 1 } | 3 PICK { n1 2 } |
\>>
S12
\<<
DUP { s1 1 s2 1 } |
OVER { s1 1 s2 -1 } |
3 PICK { s1 -1 s2 1 } |
4 PICK { s1 -1 s2 -1 } |
\>>
END