一百個例題 (30 ~ 34)
Ching-Tang Tseng
Hamilton, New Zealand
31 August 2024
\ (30)實數係數一元二次方程式的根.f \ 適用於 abc657 以後版本。 \ 最新修正日期:20150220 \ (30)QuadraticEq.f \ ABC FORTH file I/O demo code \ Author : Ching-Tang Tseng, Hamilton NZ \ Date : 6 Aug 2012 \ Contact : ilikeforth@gmail.com \ Website : http://forthfortnight.blogspot.com 2 Integers I N 20 3 MATRIX coef \ BRA(i) is a primitive BASIC style Real Array in ABC FORTH : ReadCoef ( -- ) BASIC 10 run S" (30-1)QuadraticEqCoeff.f" Get-File 20 run GetOneLineData 30 let N = INT ( BRA ( 1 ) ) 40 for I = 1 to N 50 run GetOneLineData 60 let { coef ( I 1 ) = BRA ( 2 ) } 70 let { coef ( I 2 ) = BRA ( 3 ) } 80 let { coef ( I 3 ) = BRA ( 4 ) } 90 next I 100 end ; 9 Reals a b c x f(x) x1 x2 d dsq : RealRootCheck ( -- ) BASIC 10 LET { f(x) = a * x * x + b * x + c } 20 END ; 5 complexs za zb zc zx f(zx) : ComplexRootCheck ( -- ) BASIC 10 let [ za = r>zr ( a ) + r>zi ( 0 ) ] :: [ zb = r>zr ( b ) + r>zi ( 0 ) ] :: [ zc = r>zr ( c ) + r>zi ( 0 ) ] 20 let [ f(zx) = za * zx * zx + zb * zx + zc ] 30 end ; : Once ( -- ) BASIC 10 IF { a = 0 AND b = 0 } THEN 400 20 IF { a = 0 } THEN 300 30 LET { d = b * b - ( 4 * a * c ) } 40 IF { d >= 0 } THEN 100 50 GOTO 200 100 LET { dsq = SQRT ( d ) } :: { x1 = ( NEGATE b + dsq ) / ( 2 * a ) } :: { x2 = ( NEGATE b - dsq ) / ( 2 * a ) } 110 let { x = x1 } 120 run RealRootCheck 130 PRINT { " Root x1:" , x1 ; " ==> f(x1) = " , f(x) } 140 let { x = x2 } 150 run RealRootCheck 160 PRINT { " Root x2:" , x2 ; " ==> f(x2) = " , f(x) } 170 GOTO 900 200 LET { d = ABS ( ( SQRT ( ( 4 * a * c ) - b * b ) ) / ( 2 * a ) ) } 210 let { x1 = negate b / ( 2 * a ) } 220 let [ zx = r>zr ( x1 ) + r>zi ( d ) ] 230 run ComplexRootCheck 240 PRINT [ " Root x1 = " ; zx ; " ==> f(x1) = " ; f(zx) ] 245 print { " ABS(f(x1)) = " ; ZABS ( f(zx) ) } 250 let [ zx = r>zr ( x1 ) - r>zi ( d ) ] 260 run ComplexRootCheck 270 PRINT [ " Root x2 = " ; zx ; " ==> f(x2) = " ; f(zx) ] 275 print { " ABS(f(x2)) = " ; ZABS ( f(zx) ) } 280 GOTO 900 300 LET { x1 = NEGATE c / b } 310 let { f(x) = b * x1 + c } 320 PRINT { " This equation has only one root x = " ; x1 ; " ==> f(x) = " ; f(x) } 330 GOTO 900 400 PRINT " This is not an appropriate quadratic equation!" 900 RUN CR 910 END ; : test ( -- ) BASIC 10 LET { a = 8 } :: { b = -33.33 } :: { c = 9.876e2 } 20 PRINT { " Equation:( " ; a ; " )*x^2 + ( " ; b ; " )*x + ( " ; c ; " ) = 0" } 30 RUN ONCE 40 END ; : hi ( -- ) BASIC 10 PRINT " Typical real coefficient quadratic equation: ax^2 + bx + c = 0 " CR 20 PRINT " Please enter its three coefficients: a b c " CR 30 INPUTR a , b , c 40 RUN ONCE 50 END ; : main ( -- ) PAGE BASIC 10 RUN ReadCoef 20 run S" (30-2)OutputResult.f" new-file 30 run >file 40 FOR I = 1 TO N 50 LET { a = COEF ( I 1 ) } :: { b = COEF ( I 2 ) } :: { c = COEF ( I 3 ) } 60 PRINT " ( " ; I ; " )" ; { " Equation:( " ; a ; " )*x^2 + ( " ; b ; " )*x + ( " ; c ; " ) = 0" } 70 RUN Once 80 NEXT I 90 run file> 100 run S" (30-2)OutputResult.f" save-file 110 run filetype 120 END ; cr cr .( Usage: ) cr .( 1. test : for fixed data set using. ) cr .( 2. hi : for interactive input data using. ) cr .( 3. main : for file I/O data sets using. ) cr \S cr cr .( 程式用法: ) cr .( 1. test : 固定的輸入數據時使用。 ) cr .( 2. hi : 交談式輸入數據時使用。 ) cr .( 3. main : 由檔案輸入數據時使用。 ) cr
\ (31-1)FloatDot.f \ Hans Bezemer \ SFPOUT.F \ \ Simple Floating Point Output \ \ Don't attempt to output non-real numbers such as \ NANs or INFs as it will hang. \ Floating-point pictured numeric output operators : <#. ( F: r1 -- r2 ) FROUND <# ; : #. ( F: r1 -- r2 ) 10.E F/ FDUP FLOOR FSWAP FOVER F- 10.E F* FROUND F>D D>S [CHAR] 0 + HOLD ; : #S. ( F: r1 -- r2 ) BEGIN #. FDUP F0= UNTIL ; : #>. ( F: r -- ) ( c-addr u ) FDROP 0 0 #> ; : SIGN. ( flag -- ) IF [CHAR] - HOLD THEN ; [UNDEFINED] S>F [IF] : S>F ( n -- r ) S>D D>F ; [THEN] VARIABLE FDP FDP ON \ decimal point control : 10^n ( r1 n -- r2 ) 0 ?DO 10.E F* LOOP ; : #.n ( r1 n -- r2 ) 0 ?DO #. LOOP ; 1 VALUE rscale 10 VALUE rstep \ Normalize to range 1.0 <= r < STEPSIZE : fnorm ( r1 -- |r2| sign exp ) FDUP F0< 0 2>R FABS FDUP F0= 0= IF BEGIN FDUP rstep S>F F< 0= WHILE rstep S>F F/ R> rscale + >R REPEAT BEGIN FDUP 1.0E F< WHILE rstep S>F F* R> rscale - >R REPEAT THEN 2R> ; \ Convert real number r to string c-addr u in exponential \ notation with n places right of the decimal point. : f(e.) ( r n scale step -- c-addr u ) TO rstep TO rscale 0 MAX >R fnorm R> 2>R IF FNEGATE THEN 1.E R@ 10^n FSWAP FOVER F* FROUND ( make integer) FDUP FABS FROT F/ rstep S>F F< 0= IF ( overflow) rstep S>F F/ R> R> rscale + >R >R THEN <#. R> R> S>D TUCK DABS # #S 2DROP 0< IF [CHAR] - ELSE [CHAR] + THEN HOLD [CHAR] E HOLD >R FDUP F0< ( sign) R> 2>R FABS FDP @ IF ( always output decimal point ) R> #.n [CHAR] . HOLD ELSE ( conditionally output decimal point ) R@ #.n R> IF [CHAR] . HOLD THEN THEN #S. R> SIGN. #>. ; \ Convert real number r to string c-addr u in scientific \ notation with n places right of the decimal point. : f(FS.) ( r n -- c-addr u ) 1 10 f(e.) ; \ Display real number r in scientific notation right- \ justified in a field width u with n places right of \ the decimal point. : FS.R ( r n u -- ) >R f(FS.) R> OVER - SPACES TYPE ; \ Convert real number r to string c-addr u in engineering \ notation with n places right of the decimal point. : f(FE.) ( r n -- c-addr u ) 3 1000 f(e.) ; \ Display real number r in engineering notation right- \ justified in a field width u with n places right of \ the decimal point. : FE.R ( r n u -- ) >R f(FE.) R> OVER - SPACES TYPE ; \ Convert real number r to string c-addr u in fixed-point \ notation with n places right of the decimal point. : f(F.) ( F: r -- ) ( n -- c-addr u ) 0 MAX DUP >R 10^n <#. ( round) FDUP F0< ( sign) R> 2>R FABS R> #.n [CHAR] . HOLD #S. R> SIGN. #>. ; \ Display real number r in fixed-point notation right- \ justified in a field width u with n places right of \ the decimal point. : F.R ( F: r -- ) ( n u -- ) >R f(F.) R> OVER - SPACES TYPE ; \ end fvariable fpPAD 0 fpPAD 2 cells + W! 0 fpPad cell + ! 1 fpPAD ! \\\\\\\\\\\\\\\\\\\\\\\\\\\ \ (31-2)FloatDot.f CREATE FPOWERS 1E0 F, 1E1 F, 1E2 F, 1E3 F, 1E4 F, 1E5 F, 1E6 F, 1E7 F, 1E8 F, 1E9 F, 1E10 F, 1E11 F, 1E12 F, 1E13 F, 1E14 F, 1E15 F, 1E16 F, 1E17 F, 1E18 F, : f(F.) ( -- c_addr u ) ( float: r -- ) FDUP F0< FABS FDUP FLOG F>S ( minus? log10[r] ) ( float: r ) 0 MAX \ for small r, trade readability for precision <# >R PRECISION 1- R@ - ( minus? trailing ) ( R: log10[r] ) DUP 0< IF DROP \ r > 10^PRECISION R> 18 - 0 MAX DUP >R \ assuming decimal BASE, 0 ?DO 10E0 F/ LOOP F>D \ reduce range if too big for # ELSE \ ordinary numbers PRECISION FLOATS FPOWERS + F@ F* F>D \ r*10^PRECISION R> 0 ?DO # LOOP 5 0 D+ # \ round <# ROT 0 ?DO # LOOP 0 >R \ after decimal THEN [CHAR] . HOLD R> 0 ?DO [CHAR] 0 HOLD LOOP \ big num overflow #S ROT SIGN #> \ before decimal ; \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ (31-3)FloatDot.f \ Convert float to string 2013.10.17 BNE CREATE FPOWERS 1E0 F, 1E1 F, 1E2 F, 1E3 F, 1E4 F, 1E5 F, 1E6 F, 1E7 F, 1E8 F, 1E9 F, 1E10 F, 1E11 F, 1E12 F, 1E13 F, 1E14 F, 1E15 F, 1E16 F, 1E17 F, 1E18 F, : [PRS] FLOATS FPOWERS + F@ ; : F.RIGHT ( .right d -- d' ) 5 0 D+ # <# ROT 0 ?DO # LOOP ; : f(F.) ( -- c_addr u ) ( float: r -- ) <# FDUP F0< FABS 0 BEGIN FDUP DUP 1+ [PRS] F< 0= OVER 18 < AND WHILE 1+ REPEAT >R PRECISION 1- R@ - ( -? .right | r: log10[r]) DUP 0< IF DROP \ r >= 10^PRECISION R> 18 - 0 MAX DUP >R \ assuming decimal BASE, 0 ?DO 10E0 F/ LOOP F>D \ reduce range if too big for # ELSE PRECISION [PRS] F* F>D \ r * 10^PRECISION R> 0 ?DO # LOOP F.RIGHT 0 >R \ rounded, after decimal THEN [CHAR] . HOLD R> 0 ?DO [CHAR] 0 HOLD LOOP \ 0overflow #S ROT SIGN #> ; \ left of decimal \ Float to string with fixed number of digits after the decimal : (F.F) ( digits -- c_addr u ) ( float: r -- ) FDUP F0< SWAP FABS DUP 1+ [PRS] F* F>D <# F.RIGHT [CHAR] . HOLD #S ROT SIGN #> ;
\ (32)Zsqrt.f 5 reals a b c d |Bz| : Bzq ( f: c d -- a b ) {{ d }} f! {{ c }} f! BASIC 10 let { |Bz| = sqrt ( c * c + d * d ) } 20 let { a = sqrt ( abs ( |Bz| + c ) / 2 ) } 30 let { b = sqrt ( abs ( |Bz| - c ) / 2 ) } 40 if { d < 0 } then 60 50 goto 70 60 let { b = negate ( b ) } 70 end {{ a }} f@ {{ b }} f@ ; : test ( f: r1 r2 -- ) zdup cr cr zsqrt z. cr cr bzq fswap fs. fs. ." i " cr cr ; 20 sigdigits !
\ (33)VariablesTest.f integer i 3 variables a b c : test1 BASIC 10 let a = 1 :: b = 2 :: c = 3 20 for i = 1 to 10 30 let a = a @ + b @ + c @ 40 run cr a @ . b @ . c @ . 50 next i 60 run cr a @ . 70 end ;
\ (34)FLocal.f 8 CONSTANT /flocals : (frame) ( n -- ) FALIGN FLOATS ALLOT ; : |FRAME ( n -- ) /flocals NEGATE (frame) ; : FRAME| 0 >R BEGIN BL WORD COUNT 1 = SWAP C@ [CHAR] | = AND 0= WHILE R@ 0= IF POSTPONE FALIGN ENDIF POSTPONE F, R> 1+ >R REPEAT /flocals R> - DUP 0< ABORT" too many flocals" POSTPONE LITERAL POSTPONE (frame) ; IMMEDIATE : *h HERE 1 FLOATS - ; : *g HERE 2 FLOATS - ; : *f HERE 3 FLOATS - ; : *e HERE 4 FLOATS - ; : *d HERE 5 FLOATS - ; : *c HERE 6 FLOATS - ; : *b HERE 7 FLOATS - ; : *a HERE 8 FLOATS - ; : a *a F@ ; : b *b F@ ; : c *c F@ ; : d *d F@ ; : e *e F@ ; : f *f F@ ; : g *g F@ ; : h *h F@ ; : func1 ( F: r1 r2 -- r3 ) FRAME| b a | CR ." b = " b F. ." a = " a F. a b F+ ." a + b = " fdup F. |FRAME ; : func2 ( F: r1 -- ) FRAME| a | CR ." a = " a F. FPI 2e fln func1 CR ." a = " a F. ." result = " a F* F. |FRAME ; 12.34e func2 \s a = 12.340000 a = 0.693147 b = 3.141593 a + b = 3.834740 a = 12.340000 result = 47.320690 ok
沒有留言:
張貼留言