一百個例題 (46 ~ 50)
Ching-Tang Tseng
Hamilton, New Zealand
12 September 2024
\ (46)Lagrange插值多項式曲線調適.f
\ 原始設計日期:2012-08-06
\ 原本設計ABC FORTH系統的陣列與矩陣時,並未規劃指標為0時的儲存方式。
\ 規劃完成後,下列程式方得以執行。
\ ABC Forth demo code: Lagrange interpolating polynomial curve fitting.
\ Author: Ching-Tang Tseng, Hamilton, New Zealand
\ Date: 2015-04-09
\ Contact: ilikeforth@gmail.com
\ Reference:
\ Lawrence J. Mayes ELECTRONIC ENGINEERING, 57, No 698; FEBRUARY 1985 p 38.
\ Description:
\ This program uses a method based on the Lagrange interpolating polynomial.
\ ZZ(i) is the input raw data array.
\ Matrix AAA(i,j) is the difference table manipulation matrix.
\ HH(i) is the output coefficients array of the fitted polynomial.
5 INTEGERS I J N N1 P
: INPUT-ORDER BASIC
10 PRINT " Order of fit: "
20 INPUTI P
30 IF P > 56 THEN 50
40 GOTO 70
50 PRINT " Order P can not > 56, Re-enter please. "
60 GOTO -10
70 END ;
56 ARRAY ZZ
: SUB245 BASIC
10 RUN INPUT-ORDER
20 PRINT " Input data: "
30 PRINT " =========== "
40 FOR I = 0 TO P \ 指標從0開始
50 PRINT " Y value for X abscissa value: " ; I
60 INPUTR ZZ ( I )
70 PRINT " Y( " ; I ; " )=" ; { ZZ ( I ) } \ 注意前一I為整數
80 NEXT I
90 END ;
57 ARRAY CC
: SUB235 BASIC
10 FOR I = 0 TO P + 1 \ 指標可為算式
20 LET { CC ( I ) = 0 }
30 NEXT I
40 END ;
56 ARRAY HH
57 56 MATRIX AAA
: SUB275 BASIC
10 PRINT " Polynomial fit: "
20 PRINT " =============== "
30 FOR I = 0 TO P
40 LET { HH ( I ) = 0 }
50 NEXT I
60 FOR J = 0 TO P
70 FOR I = 0 TO P
80 LET { HH ( I ) = ZZ ( J ) * AAA ( I J ) + HH ( I ) }
90 NEXT I
100 NEXT J
110 FOR I = 0 TO P
120 PRINT " HH( " ; I ; " )= " ; { HH ( I ) }
130 NEXT I
140 END ;
INTEGER I-1
: SUB220 BASIC
10 FOR I = P TO 1 STEP -1
20 LET I-1 = I - 1
30 LET { CC ( I-1 ) = CC ( I ) * I>R ( J ) + CC ( I-1 ) }
40 NEXT I
50 END ;
INTEGER Q
REAL B0
: MAIN BASIC
10 RUN SUB245
20 FOR J = 0 TO P
30 RUN SUB235
40 LET { CC ( 0 ) = 1 }
50 FOR N = 0 TO P
60 LET N1 = N + 1
70 IF N = J THEN 90
80 GOTO 100
90 LET N = N + 1
100 IF N > P THEN 200
105 LET Q = NEGATE N
110 LET { B0 = I>R ( Q ) }
120 FOR I = 1 TO N1
130 LET I-1 = I - 1
\ 下式實際上就是差值 CC(i-1)-CC(i)
140 LET { AAA ( I J ) = B0 * CC ( I ) + CC ( I-1 ) }
150 NEXT I
160 LET { AAA ( 0 J ) = B0 * CC ( 0 ) }
170 FOR I = 0 TO N1
180 LET { CC ( I ) = AAA ( I J ) }
190 NEXT I
200 NEXT N
210 RUN SUB220
220 FOR I = 0 TO P
230 LET { AAA ( I J ) = AAA ( I J ) / CC ( 0 ) }
240 NEXT I
250 NEXT J
260 RUN SUB275
270 PRINT " Finished."
280 END ;
\ 使用例:
\ 先執行下列指令 GIVEN 以便獲得可用之輸入數據
\ 再執行 MAIN 然後於對答時輸入由 GIVEN所獲得的數據
: GIVEN BASIC
10 RUN CR CR
20 FOR I = 0 TO 5
30 PRINT " Y( " ; I ; " )= " ; { EXP ( I>R ( I ) ) }
40 NEXT I
50 RUN CR CR
60 END ;
\S
參考文獻及執行結果:
***********************************************************
100 COM A(57,56), C(57), H(56), Z(56)
105 INTEGER I, J, N, N1, P
110 CLEAR
115 LINPUT "Order of fit:",P$ : P = VAL(P$) : IF P > 56 THEN BEEP : GOTO 115
120 GOSUB 245
125 FOR J = 0 TO P
130 GOSUB 235
135 C(0) = 1
140 FOR N = 0 TO P
145 N1 = N + 1
150 IF N = J THEN N = N + 1
155 IF N > P THEN 190
160 B0 = -N
165 FOR I = 1 TO N1
170 A(I,J) = B0 * C(I) + C(I-1)
175 NEXT I
180 A(0,J) = B0 * C(0)
185 FOR I = 0 TO N1 : C(I) = A(I,J) : NEXT I
190 NEXT N
195 GOSUB 220
200 FOR I = 0 TO P : A(I,J) = A(I,J)/C(0) : NEXT I
205 NEXT J
210 GOSUB 275
215 BEEP 100,190 : DISP "finished" : STOP
220 FOR I = P TO 1 STEP -1
225 C(I-1) = C(I) * J+C(I-1) : NEXT I
230 RETURN
235 FOR I = 0 TO P + 1 : C(I) = 0 : NEXT I
240 RETURN
245 PRINT : PRINT "INPUT DATA" : PRINT "==========" : PRINT
250 FOR I = 0 TO P
255 DISP : DISP "Y value for abscissa value:"; I : INPUT Z(I)
260 PRINT "Z("; I; ")= "; Z(I)
265 NEXT I
270 RETURN
275 PRINT : PRINT "POLYNOMIAL FIT" : PRINT "==============" : PRINT
280 FOR I = 0 TO P : H(I) = 0 : NEXT I
285 FOR J = 0 TO P
290 FOR I = 0 TO P
295 H(I) = Z(J) * A(I,J) + H(I)
300 NEXT I
305 NEXT J
310 FOR I = 0 TO P : PRINT "H("; I; ")= "; H(I) : NEXT I
315 RETURN
320 END
**************************************************
我的執行結果如下
GIVEN
Y( 0 )= 1.00000000000
Y( 1 )= 2.71828182846
Y( 2 )= 7.38905609893
Y( 3 )= 20.0855369232
Y( 4 )= 54.5981500331
Y( 5 )= 148.413159103
ok
MAIN
Order of fit: ? 5
Input data:
===========
Y value for X abscissa value: 0 ? 1.00000000000
Y( 0 )= 1.00000000000
Y value for X abscissa value: 1 ? 2.71828182846
Y( 1 )= 2.71828182846
Y value for X abscissa value: 2 ? 7.38905609893
Y( 2 )= 7.38905609893
Y value for X abscissa value: 3 ? 20.0855369232
Y( 3 )= 20.0855369232
Y value for X abscissa value: 4 ? 54.5981500331
Y( 4 )= 54.5981500331
Y value for X abscissa value: 5 ? 148.413159103
Y( 5 )= 148.413159103
Polynomial fit:
===============
HH( 0 )= 1.00000000000
HH( 1 )= 2.74952933754
HH( 2 )= -3.30606647675
HH( 3 )= 3.03499879102
HH( 4 )= -.885001709373
HH( 5 )= .124821886021
Finished. ok
驗證無誤
**************************************************
原始資料輸出結果如下
H0 = 1
H1 = 2.74952
H2 = -3.30606
H3 = 3.03500
H4 = -.885002
H5 = .124822
**************************************************
(1)輸入之 X(i) 值固定為整數值 0 ... n,Y(i)值則需人工輸入,但可以為浮點數。
(2)程式中不存 X(i) 之值。只存 Y(i)之值。存於 ZZ(i) 陣列中。
(3)本程式中使用之 Y(i) 輸入範例為 exp(X(i)) 之值,為方便起見,加建了GIVEN指令。
(4)GIVEN執行後,可直接提供 exp(0) ... exp(5) 六個 Y(i) 值,做為對答時輸入之用。
(5)執行 main 指令後得到的 6 個 HH(0) ... HH(5) 係數,即為所求多項式的係數答案。
(6)本程式的缺點是輸入數據只能為整數的固定差值 0, 1, 2, 3 .... n ,不能為其他值。
(7)程式應用範圍被限制於最大為 56,因為陣列 ZZ(56) 及矩陣 AAA(57,56)
被設定成只能操作於 56 個單元的上限量。
(8)就建立差分表(difference table)應用於求取內插值(interpolation)問題的數值分析
技術研究而言,這是一個很直接便能了解之在列表內(在矩陣 AAA(i,j)內)操作計算的
良好範例。
(9)本程式設計成只處理等距數據(equally spaced data),若欲處理不均勻差量數據
(nonuniformly spaced data),可修改原始資料內的程式160列內容來達到目的。
(10)2015年時,這方面的技術已發展得相當完善,網上已有許多公益程式可以參考使用,
故不對此程式進行任何修改,僅就現況使用或研究便可。
(11)插值技術的應用,主要是強調內插(interpolation)而非外插(extrapolation),因此,
插值範圍以外的數值不應以內插結果來求取。
(12本程式的輸出結果,可以利用函數繪圖程式予以圖形表示效果。
(13)精確度設定為 6 位數時的執行結果如下:
given
Y( 0 )= 1.00000
Y( 1 )= 2.71828
Y( 2 )= 7.38906
Y( 3 )= 20.0855
Y( 4 )= 54.5982
Y( 5 )= 148.413
ok
main
Order of fit: ? 5
Input data:
===========
Y value for X abscissa value: 0 ? 1
Y( 0 )= 1.00000
Y value for X abscissa value: 1 ? 2.71828
Y( 1 )= 2.71828
Y value for X abscissa value: 2 ? 7.38906
Y( 2 )= 7.38906
Y value for X abscissa value: 3 ? 20.0855
Y( 3 )= 20.0855
Y value for X abscissa value: 4 ? 54.5982
Y( 4 )= 54.5982
Y value for X abscissa value: 5 ? 148.413
Y( 5 )= 148.413
Polynomial fit:
===============
HH( 0 )= 1.00000
HH( 1 )= 2.74928
HH( 2 )= -3.30559
HH( 3 )= 3.03469
HH( 4 )= -.884923
HH( 5 )= .124815
Finished. ok
\ (47)Howlong.f \ 應用 GerTicks 實測執行指令時,所耗用之CPU時脈(clock pulses)數量 \ get the ticks as soon as possible without any tedious code VARIABLE CLK0H VARIABLE CLK0L VARIABLE CLK1H VARIABLE CLK1L : Mark0 ( -- ) GetTicks CLK0H ! CLK0L ! ; : Mark1 ( -- ) GetTicks CLK1H ! CLK1L ! ; \ ignore the most significant bit by doing ABS to the high byte \ this bit is impossible changed in a short period of time while testing \ it can proved that ticks number is always to be a positive integer : HowLong ( -- ) CLK1L @ CLK1H @ ABS CLK0L @ CLK0H @ ABS DNEGATE D+ D. ; \ USAGE: \ (1) Mark0 NOOP Mark1 or \ (2) Mark0 3 5 + Mark1 \ (3) HowLong
\ (48)RANDOM.F VARIABLE SEED 987654321 SEED ! : RENEWRANDOM ( -- ) GetTicks DROP SEED ! ; : COOKING ( n -- n ) DUP 13 LSHIFT XOR DUP 5 RSHIFT XOR DUP 7 LSHIFT XOR ; : RND ( -- ) SEED @ COOKING DUP SEED ! ABS 1- ; : RANDOM ( n -- n ) RND SWAP MOD ;
\ Monte Carlo on the Pi.f
\ a place to keep a count of points that lie within the circle
\ (all points lie within the square, so no need to count them)
variable in-circle
\ square a number ( n -- n^2 )
: square dup * ;
\ generate a 2D point ( -- x y )
: point 1000 random 1000 random ;
\ determine if point lies within the circle ( x y -- flg )
: in-circle? square swap square + 1000000 < ;
\ run a simulation of n points ( n -- )
\ reset within circle counter
\ generate a point, test for within circle
\ count points within circle
\ do next point
: sim
0 in-circle !
0 do point in-circle?
if 1 in-circle +! then
loop ;
: pi sim 4 in-circle @ * cr . ;
((
run a simulation, calculate pi, and print result
(don't divide by area of square because we want all digits)
Here are some test runs:
1000 pi 3232
10000 pi 31472
100000 pi 314096
))
\ dump.4th \ \ memory dump utility \ \ Copyright (c) 1999 Krishna Myneni \ Creative Consulting for Research and Education \ \ This software is provided under the terms of the GNU \ General Public License. \ \ Last Revised: 4-25-1999 \ create dump_display_buf 20 allot : hexchar ( n -- m | return ascii hex char value for n: 0 - 15 ) dup 9 > if 10 - 65 + else 48 + then ; : dump_display_char ( n -- n|46 ) dup 33 < over 126 > or if drop 46 then ; : ddump ( a n -- | display n bytes starting at a ) dup 0> if 0 do i 16 mod 0= if cr dup . 58 emit 2 spaces then dup c@ 16 /mod hexchar emit hexchar emit 2 spaces dup c@ dump_display_char dump_display_buf i 16 mod + c! i 16 mod 15 = if dump_display_buf 16 type then 1+ loop drop else 2drop then ;
沒有留言:
張貼留言