一百個例題 (51 ~ 55)
Ching-Tang Tseng
Hamilton, New Zealand
15 September 2024
\ Simple Floating-Point Output
\ Revision 2013-10-29
\ This simple floating-point output package has features found in more comprehensive implementations yet
\ is remarkably compact and portable. Based on code and algorithm from Forth Inc.
\ SFPOUT.F
\
\ Simple Floating Point Output
\
\ Main words:
\
\ (F.) (FS.) (FE.) F.R FS.R FE.R F. FS. FE.
\ FDP PLACES
\
\ This package should function correctly on any Forth
\ system with the following limitations:
\
\ - Don't attempt to output non-numbers such as NANs
\ or INFs as it will enter an infinite loop.
\ - Floating-point strings are limited to the size of
\ the system's pictured numeric output buffer.
\
\ History:
\ 131029 Fix (F.) to use FDP. Add F. FS. FE. PLACES
FORTH DEFINITIONS DECIMAL
\ 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 ;
\ Variable controlling trailing decimal point display.
\ Default (ON) is to always display decimal point.
VARIABLE FDP 1 FDP !
: 10^n ( r1 n -- r2 ) 0 ?DO 10.E F* LOOP ;
: #.n ( r1 n -- r2 ) 0 ?DO #. LOOP ;
VARIABLE rscale 1 rscale !
FVARIABLE rstep 10.E rstep F!
VARIABLE fdpl 4 fdpl !
\ 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 F@ F< 0=
WHILE rstep F@ F/ R> rscale @ + >R REPEAT
BEGIN FDUP 1.0E F<
WHILE rstep F@ F* R> rscale @ - >R REPEAT
THEN 2R> ;
\ Convert fixed-point
: fcvt ( r n -- )
>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 exponential
\ notation with n places right of the decimal point.
: (e.) ( r n scale step -- c-addr u )
rstep F! 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 F@ F< 0= IF ( overflow)
rstep 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 fcvt ;
\ Convert real number r to string c-addr u in scientific
\ notation with n places right of the decimal point.
: (FS.) ( r n -- c-addr u ) 1 10.E (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 (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.
: (FE.) ( r n -- c-addr u ) 3 1000.E (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 (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.) ( r n -- c-addr u )
0 MAX DUP >R 10^n <#. ( round) R> fcvt ;
\ 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 ( r n u -- ) >R (F.) R> OVER - SPACES TYPE ;
\ Set decimal places control for F. FS. FE.
: PLACES ( n -- ) fdpl ! ;
: F. ( r -- ) fdpl @ 0 F.R SPACE ;
: FS. ( r -- ) fdpl @ 0 FS.R SPACE ;
: FE. ( r -- ) fdpl @ 0 FE.R SPACE ;
[DEFINED] DXFORTH [IF] behead 10^n (e.) [THEN]
\ end
\ elimit.f
integer i
2 reals x n
1000 array x
: x(n)
BASIC
10 for i = 1 to 1000
20 let { n = i>r ( i ) }
20 let { x ( i ) = ( 1 + 1 / ln ( n ) ) ^ n }
30 next i
40 end
;
: main
BASIC
10 run x(n)
20 print " x( 1) = " ; { x ( 1 ) }
30 print " x( 10) = " ; { x ( 10 ) }
40 print " x( 100) = " ; { x ( 100 ) }
50 print " x(1000) = " ; { x ( 1000 ) }
60 end
;
\s
c file: elimit.f
c
double precision x
dimension x(1000)
c
print *
print *,' Slowly converging sequence for irrational number e'
print *,' Section 1.2, Kincaid-Cheney'
print *
c
do 2 n=1,1000
x(n) = (1.0d0 + 1.0d0/dble(n))**n
2 continue
c
print *,' 1, x(1) =',x(1)
print *,' 10, x(10) =',x(10)
print *,' 30, x(30) =',x(30)
print *,' 50, x(50) =',x(50)
print *,' 1000, x(1000) =',x(1000)
print *,' exp(1.0) =',exp(1.0d0)
print *
print *,' error =',abs(x(1000) - exp(1.0d0))
c
stop
end
\ 2**(-n)
((
c
c Second Edition
c Numerical Analysis:
c The Mathematics of Scientific Computing
c D.R. Kincaid and E.W. Cheney
c Brooks/Cole Publ., 1996
c ISBN 0-534-33892-5
c COPYRIGHT (c) 1996
c
c Section 2.1
c
c Computing an approximate value of machine precision
c
c
c file: epsi.f
c
print *
print *,' Approximate value of machine precision'
print *,' Section 2.1, Kincaid-Cheney'
print *
print *,' n computed 2**(-n)'
c
s = 1.0
c
do 2 k=1,100
s = 0.5*s
t = s + 1.0
if (t .le. 1.0) then
s = 2.0*s
t = 1.0/2.0**(k-1)
print 3,k-1,s,t
stop
endif
2 continue
c
3 format (i3,2x,2(e13.6,2x))
stop
end
))
2 integers k k-1
2 reals s t
20 sigdigits !
: main
BASIC
10 let { s = 1 }
20 for k = 1 to 100
30 let { s = 0.5 * s }
40 let { t = s + 1 }
50 if { t <= 1 } then 100
60 let { s = 2 * s }
70 let k-1 = k - 1
80 let { t = 1 / ( 2 ^ i>r ( k-1 ) ) }
90 print " " ; k-1 , { s , t }
100 next k
110 end
;
: main2
basic
10 for k = 1 to 100
20 let { t = 1 / ( 2 ^ i>r ( k ) ) }
30 print " " ; k , { t }
40 next k
50 end
;
\ (54)nCrAndnPr.f
\ 二項式的係數可以應用 nCr 求得
\ 用法:執行 10 5 nCr big. 可得 (1+x)^10 之第 5 項係數為 252
\ 注意!使用 n r nCr 或 n r nPr 時 r 必須 >0 且 r 不得為 0
\ 使用 n r nCrOrg 則 r 可以 = 0
\ 定義 :: nCr = n! / ( (n-r)! * r! ) :: nPr = n! / (n-r)!
1 bigvariable n! 20000 allot
1 bigvariable (n-r)! 20000 allot
1 bigvariable r! 20000 allot
1 bigvariable d 20000 allot
3 integers k n r
: nCrOrg ( n r -- addr ) \ get addr of big d, r>=0
[[ r ]] ! [[ n ]] !
basic
10 LET b{ n! = big1 }b :: b{ (n-r)! = big1 }b
:: b{ r! = big1 }b :: b{ d = big1 }b
20 FOR k = 1 TO n
30 LET b{ n! = n! * i>big ( k ) }b
40 NEXT k
50 FOR k = 1 TO n - r
60 let b{ (n-r)! = (n-r)! * i>big ( k ) }b
70 next k
80 for k = 1 to r
90 let b{ r! = r! * i>big ( k ) }b
100 next k
110 let b{ d = n! / ( (n-r)! * r! ) }b
\ 120 run d big.
130 end
d \ big.
;
: nCr ( n r -- addr ) \ get addr of big d, r>0, r=/=0
[[ r ]] ! [[ n ]] !
basic
10 LET b{ n! = big1 }b :: b{ r! = big1 }b :: b{ d = big1 }b
20 FOR k = n - r + 1 TO n
30 LET b{ n! = n! * i>big ( k ) }b
40 NEXT k
50 FOR k = 1 TO r
60 let b{ r! = r! * i>big ( k ) }b
70 next k
80 let b{ d = n! / r! }b
\ 90 run d big.
100 end
d \ big.
;
: nPr ( n r -- addr ) \ get addr of big d, r>0, r=/=0
[[ r ]] ! [[ n ]] !
basic
10 let b{ d = big1 }b
20 for k = n - r + 1 to n
30 let b{ d = d * i>big ( k ) }b
40 next k
\ 50 run d big.
60 end
d \ big.
;
variable m
: test ( n -- )
m !
page
m @ 1+ 0
do
cr
." Term ( " m @ . ." , " I . ." ):"
m @ I nCrOrg big.
cr
loop
;
\ Usage: 100 test
\S
ok
10 5 nCr big.
3 digits
252 ok
49 6 nCr big.
8 digits
13983816 ok
200 100 nCr big.
59 digits
90548514656103281165404177077484163874504589675413
336841320 ok
10000 5000 nCr big.
3009 digits
15917902635324389483375972736415211886530058374576
14550428319103517772637120095798663262853944222217
74335859829932262055804632908708020739850879872195
95848962041757866458580184099587512068914331597813
53174051453473199670521394502538477277336008312053
78448823951274321755502883180927364644281795459349
36890023546288054736628292721322091972680306215783
97698552486834508478688949946112620233602352989894
58928488427591110374321646235202929095545845304023
49292778714312397841036259290830007542173305536549
24253683062815307296533408892556506908751506476159
44622376204326852230062678211259375951657115342848
24533318106868409528400428469950435925781799643074
13894226494475866262818621837575412803625468813885
44759125956185871468454381861463662350728468211441
65546574399328400579417002212869168618937974722788
62022397883728976020496710189761906178593058261688
08117556117796960379809282174855477301204105813490
54627159851188661377744154110563694305682072524481
94310502564874945796288376042950798729141780053010
24149340722579759834860211640098545723183096418633
68889831214559707246945445665178908193538606256602
93683165225062715958242340375627937873328871136143
52737971292965638066368798136853809235306441396478
97981427998980441958797431047888940127197101544121
68400963446529395285243067100038066963076992572201
04426311836533049067512198270012436774453339363870
02281179253561881400957197317504497933395227608620
35738939329776832343771264615030169561499601195082
06705891127875644018328002477885570580594271739655
61724727970366569861808080196554123575656465556543
39707955136421179968234829408914932867170470389361
58996297545140449708716896119990505242038078767450
45086398524630406716702026949125606462058300176130
06222847575106625661061937714355872185378096200269
13816305961756296827876710659465040754767228071475
82168701916632425820168589328145494184963321901025
03263315943618316059553444266801897513519884512933
06946591872301020473208721181284611163964165765568
93394074097665692587872816840693520731443017872513
61780157927471147290158311709071711945782984829441
64359840658473384707719418659651955333974514346503
81761619761261615704035455946677454877741276547147
86635414188001119626029573352659456865843697213096
86983612640564990207924247805354140963069566603071
19593156917262680235151820878651554693737963876050
46437155479530978766508167970001769266592869187570
94175117347665748132703540903393455409827319346571
30920200412827961158882797284732350179796997256267
19728263470177566063313040160755515205233184045927
56797612244679324194846919392918520452394577675953
32686906744319279375609565885643212422852240351665
84543197040090546963296363638177915596412050056857
02690372838060388519713403611629040056633420468941
76159382456860877054526939045603888375597321562922
27663423267910309912054892793591354641456968021307
92488795541350742383065293811197486421347908348956
55794152699977683783414705903919974789150191636363
96775919453875351801524980522104507017055088380935
44209022455222930021060372371375638589078163387440
553649120 ok
\ (55)BinomialTable.f
: nCr ( n r -- nCr )
1 swap 0 ?do over i - i 1+ */ loop nip ;
20 value m
: onerows ( row -- )
CR
DUP 4 .R
m 1+ 0
DO dup I nCr
dup 0=
if drop else 7 .R then
LOOP
DROP ;
: Table ( -- )
CR CR 4 spaces
m 1+ 0
DO I 7 .R LOOP ( display column numbers )
m 1+ 1
DO I onerows
LOOP
;
table
沒有留言:
張貼留言