( Coppyright PPC Paris, 1986 ) DECIMAL 0 WARN ! DEGREES : COMPLEX ." Complex vocabulary" ; : PAUSE 2000 0 DO LOOP ; 3.14159265359 FCONSTANT PI 6.28318530718 FCONSTANT 2PI : COSH E^X FENTER 1/X F+ 2. F/ ; : SINH E^X FENTER 1/X F- 2. F/ ; : TANH FENTER SINH X<>Y COSH F/ ; : NORM X^2 X<>Y X^2 F+ SQRT ; : X<0? Y 1- N@ 0= X=0? OR NOT ; : Y=0? -1 Y 3 0 DO DUP @ 0= ROT AND SWAP 16 + LOOP DROP ; : Y<0? Z 1- N@ 0= Y=0? OR NOT ; : CHS_Y Z 1- 9 TOGGLE ; : EXCH DUP PAD 8 CMOVE OVER SWAP 8 CMOVE PAD SWAP 8 CMOVE ; : <>L L EXCH ; : <>Z Z EXCH ; : <>T T EXCH ; : R-P FENTER Z RCL NORM T STO X=0? IF FENTER ELSE F/ ACOS X<>Y X<0? FDROP IF CHS THEN THEN X<>Y ; : P-R X<>Y COS X=0? IF FDROP 0. THEN LASTX SIN X=0? IF FDROP 0. THEN Z RCL F* X<>Y RUP F* ; VOCABULARY COMPLEX_WORDS COMPLEX_WORDS DEFINITIONS VARIABLE STACK_INPUT VARIABLE STACK_POINTER CREATE COMPLEX_STACK 80 NALLOT CREATE REAL_STACK 80 NALLOT VARIABLE COMPLEX_STATUS : IMAG -1 COMPLEX_STATUS ! ; : REAL 0 COMPLEX_STATUS ! ; : STACK COMPLEX_STATUS @ IF COMPLEX_STACK ELSE REAL_STACK THEN ; : STACK_LEVEL DUP 5 /MOD DROP DUP 4 = IF SWAP DROP ELSE DROP STACK_POINTER @ + 4 /MOD DROP THEN 16 * STACK + ; : REAL@ REAL STACK_LEVEL RCL ; : REAL! REAL STACK_LEVEL STO ; : IMAG@ IMAG STACK_LEVEL RCL ; : IMAG! IMAG STACK_LEVEL STO ; : GETZ DUP IMAG@ REAL@ ; : PUTZ DUP REAL! X<>Y IMAG! X<>Y ; : GET_SAVE 0 GETZ 4 PUTZ ; : STACK_UP STACK_POINTER @ ?DUP IF 1- ELSE 3 THEN STACK_POINTER ! ; : STACK_DOWN STACK_POINTER @ 1+ 4 /MOD DROP STACK_POINTER ! ; : PUSHZ STACK_UP 0 PUTZ ; : CLEAR_STACK REAL_STACK 80 0 NFILL COMPLEX_STACK 80 0 NFILL 0 STACK_POINTER ! ; : STACK_DUP 0 GETZ PUSHZ ; : STACK_DROP 3 GETZ STACK_DOWN 3 PUTZ ; : Z+ 0 IMAG@ 1 IMAG@ F+ 0 REAL@ 1 REAL@ F+ ; : Z- 1 IMAG@ 0 IMAG@ F- 1 REAL@ 0 REAL@ F- ; : Z* 0 REAL@ 1 IMAG@ F* 1 REAL@ 0 IMAG@ F* F+ 0 REAL@ 1 REAL@ F* 0 IMAG@ 1 IMAG@ F* F- ; : Z/ 0 REAL@ 1 REAL@ F* 1 IMAG@ 0 IMAG@ F* F+ 0 REAL@ 1 IMAG@ F* 1 REAL@ 0 IMAG@ F* F- 0 GETZ NORM X^2 F/ X<>Y LASTX F/ ; VARIABLE VIEW_MODE VARIABLE VIEW_FLAG : PROMPT GETZ CR VIEW_MODE @ IF R-P ." z=" Y=0? X=0? OR IF F. ELSE 1. X=Y? FDROP IF ELSE F. THEN X<>Y ." E^" F. ." i" X<>Y THEN ELSE ." Z=" X=0? DUP IF ELSE F. THEN X<>Y X=0? IF IF F. THEN ELSE -1. X=Y? CHS X=Y? OVER OR FDROP X<0? IF SWAP IF ." -" THEN ELSE SWAP DROP OVER IF ELSE ." +" THEN THEN IF ELSE F. THEN DROP ." i" THEN X<>Y THEN ; : DISP 0 PROMPT ; : VIEW_RESULT VIEW_FLAG @ IF 0 PROMPT THEN ; : SET&VIEW 0 PUTZ VIEW_RESULT ; : VIEW PROMPT PAUSE 0 PROMPT ; : POLAR -1 VIEW_MODE ! VIEW_RESULT ; : RECT 0 VIEW_MODE ! VIEW_RESULT ; : ?QUERY DEPTH STACK_INPUT ! QUERY #TIB @ IF INTERPRET DEPTH STACK_INPUT @ - 0> IF ELSE 0 THEN ELSE 0 THEN ; : QUERY_DATA QUERY #TIB @ IF INTERPRET DEPTH STACK_INPUT @ - 0> IF ITOF THEN THEN ; : INPUT DEPTH STACK_INPUT ! VIEW_MODE @ IF ." r=" QUERY_DATA X=0? IF 0. ELSE ." =" QUERY_DATA THEN X<>Y P-R ELSE ." Re=" QUERY_DATA ." Im=" QUERY_DATA X<>Y THEN PUSHZ VIEW_RESULT ; : Z_TO_N ITOF Y^X X<>Y LASTX F* X<>Y ; VARIABLE ANGLE_MODE : PI ANGLE_MODE @ IF PI ELSE 180. THEN ; : 2PI ANGLE_MODE @ IF 2PI ELSE 360. THEN ; : Z_TO_1/N OVER /MOD DROP OVER ITOF 1/X Y^X X<>Y ITOF 2PI F* F+ ITOF F/ X<>Y ; VARIABLE SAVE_MODE : RAD_MODE ANGLE_MODE @ SAVE_MODE ! RADIANS -1 ANGLE_MODE ! ; : RESET_MODE SAVE_MODE @ DUP IF ELSE DEGREES THEN ANGLE_MODE ! ; : LNZ RAD_MODE R-P LN RESET_MODE ; : EXP E^X RAD_MODE P-R 0 PUTZ RESET_MODE ; : SINZ RAD_MODE COS X<>Y SINH F* 0 GETZ SIN X<>Y COSH F* RESET_MODE ; : COSZ RAD_MODE SIN X<>Y SINH F* CHS 0 GETZ COS X<>Y COSH F* RESET_MODE ; : TANZ RAD_MODE 2. F* 0 REAL! COS X<>Y 2. F* 0 IMAG! COSH F+ 0 GETZ SIN X<>Y SINH RUP F/ X<>Y RUP F/ RESET_MODE ; : ALPHA 1. F+ Z STO X<>Y T STO X<>Y NORM T STO RDN 2. F- NORM F+ FENTER LASTX F- LASTX F- 2. F/ X<>Y 2. F/ ; : ASINZ RAD_MODE ALPHA FENTER X^2 1. F- SQRT F+ LN IF CHS THEN X<>Y ASIN RESET_MODE ; : ACOSZ RAD_MODE ALPHA FENTER X^2 1. F- SQRT F+ LN IF ELSE CHS THEN X<>Y ACOS RESET_MODE ; : ATANZ RAD_MODE Z STO X<>Y 1. F+ T STO NORM X <>Z 2. F- NORM F/ LN 2. F/ 0 GETZ X<>Y 1. F+ FENTER X <>Z F/ ATAN X<>Y 2. F- 0 REAL@ F/ ATAN F- PI X<>Y F- 2. F/ RESET_MODE ; : 1/X GET_SAVE CHS_Y 0 GETZ NORM X^2 F/ X<>Y LASTX F/ X<>Y SET&VIEW ; : X^N GET_SAVE R-P Z_TO_N P-R SET&VIEW ; : ROOT GET_SAVE CR ." Order? " ?QUERY R-P Z_TO_1/N P-R SET&VIEW ; : X^2 2 X^N ; : SQRT 2 ROOT ; : Y^X GET_SAVE 1 GETZ LNZ 1 PUTZ Z* EXP 1 PUTZ STACK_DROP VIEW_RESULT ; : Y^X-1 GET_SAVE 1 GETZ LNZ 1 PUTZ Z/ EXP 1 PUTZ STACK_DROP VIEW_RESULT ; : X^Y GET_SAVE Z RCL FABS LN F* X<>Y LASTX F* X<>Y EXP SET&VIEW ; : LN GET_SAVE LNZ SET&VIEW ; : LOG 0 GETZ LNZ 0 PUTZ 1 GETZ 4 PUTZ LNZ 1 PUTZ Z/ 1 PUTZ STACK_DROP VIEW_RESULT ; : E^X GET_SAVE EXP SET&VIEW ; : SIN GET_SAVE SINZ SET&VIEW ; : COS GET_SAVE COSZ SET&VIEW ; : TAN GET_SAVE TANZ SET&VIEW ; : ASIN GET_SAVE Y<0? ASINZ SET&VIEW ; : ACOS GET_SAVE Y<0? ACOSZ SET&VIEW ; : ATAN GET_SAVE ATANZ SET&VIEW ; : SINH GET_SAVE X<>Y CHS 0 PUTZ SINZ CHS X<>Y SET&VIEW ; : COSH GET_SAVE X<>Y CHS 0 PUTZ COSZ SET&VIEW ; : TANH GET_SAVE X<>Y CHS 0 PUTZ TANZ CHS X<>Y SET&VIEW ; : ASINH GET_SAVE X<>Y CHS 0 PUTZ Y<0? ASINZ CHS X<>Y SET&VIEW ; : ACOSH GET_SAVE Y<0? ACOSZ X<>Y CHS SET&VIEW ; : ATANH GET_SAVE X<>Y CHS 0 PUTZ ATANZ CHS X<>Y SET&VIEW ; : X<>Y 1 GETZ 0 GETZ 1 PUTZ RDN RDN SET&VIEW ; : BAR GET_SAVE CHS_Y SET&VIEW ; : CHS 0 GETZ CHS_Y CHS SET&VIEW ; : RUP STACK_UP VIEW_RESULT ; : RDN STACK_DOWN VIEW_RESULT ; : LASTX 4 GETZ PUSHZ VIEW_RESULT ; : CLX 0. 0. SET&VIEW ; : CLST CLEAR_STACK VIEW_RESULT ; : FENTER STACK_DUP VIEW_RESULT ; : FDROP STACK_DROP VIEW_RESULT ; : RCL GETZ PUSHZ VIEW_RESULT ; : STO 0 GETZ PUTZ VIEW_RESULT ; : X 0 ; : Y 1 ; : Z 2 ; : T 3 ; : L 4 ; : + GET_SAVE Z+ 1 PUTZ STACK_DROP VIEW_RESULT ; : - GET_SAVE Z- 1 PUTZ STACK_DROP VIEW_RESULT ; : * GET_SAVE Z* 1 PUTZ STACK_DROP VIEW_RESULT ; : / GET_SAVE Z/ 1 PUTZ STACK_DROP VIEW_RESULT ; : STD STD VIEW_RESULT ; : FIX FIX VIEW_RESULT ; : SCI SCI VIEW_RESULT ; : ENG ENG VIEW_RESULT ; : DEGREES DEGREES 0 ANGLE_MODE ! VIEW_RESULT ; : RADIANS RADIANS -1 ANGLE_MODE ! VIEW_RESULT ; : REAL_MODE 0 OKFLG ! 0 ONERR ! CR ." Press [END] to resume" ABORT ; CLEAR_STACK REAL 0 VIEW_MODE ! 0 ANGLE_MODE ! -1 VIEW_FLAG ! FORTH FORTH DEFINITIONS : ERROR ." not recognized" QUIT ; : COMPLEX_MODE COMPLEX_WORDS DEFINITIONS -1 OKFLG ! ['] ERROR ONERR ! ;