一百個例題 (25 ~ 29)
Ching-Tang Tseng
Hamilton, New Zealand
30 August 2024
\ (25-1)正向之位元顯示器.f
\ 20140427
: 32cRuler ( -- )
CR ." =========1=========2=========3=="
CR ." 12345678901234567890123456789012"
CR ." ==== LSB --> MSB ==============="
CR
;
: 50cRuler ( -- )
CR ." =========1=========2=========3=========4=========5"
CR ." 12345678901234567890123456789012345678901234567890"
CR ." ========(c) 2014 Copyright, Counting Ruler========"
CR
;
: 64cRuler ( -- )
CR ." |========1=========2=========3=========4=========5==||======6==|"
CR ." 1234567890123456789012345678901234567890123456789012345678901234"
CR ." |=== LSB --> MSB ===================================||=========|"
CR
;
: 80cCounterRuler ( -- )
CR ." =========1=========2=========3=========4=========5=========6=========7=========8"
CR ." 12345678901234567890123456789012345678901234567890123456789012345678901234567890"
CR ." 09876543210987654321098765432109876543210987654321098765432109876543210987654321"
CR ." 8=========7=========6=========5=========4=========3=========2=========1========="
CR
;
: 32BitsDump ( un -- )
1 32
DO
0 2 UM/MOD SWAP
IF 1 0 .R ELSE 0 0 .R THEN
-1
+LOOP
DROP
;
VARIABLE iTTT
$FFFFffff iTTT !
: TEST32 ( -- )
iTTT @ CR 32BitsDump 32cRuler
;
\ : unBinaryDump ( un -- )
: unBDump
cr 32BitsDump 32cRuler
;
\ : dBinaryDump ( ud -- )
: udBDump
cr SWAP 32BitsDump 32BitsDump 64cRuler
;
\ : fpBinaryDump ( f -- )
: fpBDump
cr PAD F! PAD @ 32BitsDump PAD cell + @ 32BitsDump 64cRuler
;
FVARIABLE fTTT
1.625E0 fTTT F!
: addrBinaryDump ( addr -- )
cr DUP @ 32BitsDump CELL + @ 32BitsDump
;
: TEST64 ( -- )
fTTT CR addrBinaryDump 64cRuler
;
cr cr
.( Usage: ) cr
.( TEST32 TEST64 ) cr
.( unBDump udBDump fpBDump 32BitsDump addrBinaryDump ) cr
\s
: 32cCounterRuler ( -- )
CR ." S=3=====|S==2=========1========="
CR ." 21098765432109876543210987654321"
CR ." 01234567890123456789012345678901"
CR ." S=======|S1=========2=========3="
CR
;
: 64cCounterRuler ( -- )
CR ." S===6======|S=5=========4=========3=========2=========1========="
CR ." 4321098765432109876543210987654321098765432109876543210987654321"
CR ." 1234567890123456789012345678901234567890123456789012345678901234"
CR ." S========1=|S======2=========3=========4=========5=========6===="
CR
;
1.625E3 fTTT F! ok
test64
0000000000000000000000000000000000000000001001101001100100000010
=========1=========2=========3=========4=========5=========6====
1234567890123456789012345678901234567890123456789012345678901234
LSB --> MSB =======================================S|==========S
ok
1.625e3 fs. 1.62500E3 ok
1.625e3 f. 1625.00 ok
binary ok
11001011001 decimal . 1625 ok
\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ (25-2)反向之位元顯示器.f
\ 20140511
1 CHARS CONSTANT /char ( -- n ) \ Length of a character
: cappend ( c s -- ) \ Add c to the counted string s
1 OVER c+! COUNT 1- CHARS + C! ;
: cexchange ( ca1 ca2 -- ) \ Swap characters of ca1 and ca2
2DUP 2>R C@ SWAP C@ R> C! R> C! ;
: squeeze ( a1 a2 n -- a1+n a2-n ) \ Add/subtract n to/from a1/a2
TUCK - >R + R> ;
: turn ( ca u -- ) \ Reverse string ca u
1- CHARS OVER + ( start-addr end-addr )
BEGIN 2DUP U< WHILE 2DUP cexchange /char squeeze REPEAT 2DROP ;
: 32cRuler ( -- )
CR ." ==3=========2=========1========="
CR ." 21098765432109876543210987654321"
CR ." ==== MSB <-- LSB ==============="
CR
;
: 50cRuler ( -- )
CR ." =========1=========2=========3=========4=========5"
CR ." 12345678901234567890123456789012345678901234567890"
CR ." ========(c) 2014 Copyright, Counting Ruler========"
CR
;
: 64cRuler ( -- )
CR ." S|==6======||=5=========4=========3=========2=========1========|"
CR ." 4321098765432109876543210987654321098765432109876543210987654321"
CR ." $===$===$===$===$===$===$===$===$===$= MSB <-- LSB =$===$===$==="
CR
;
: 96cRuler ( -- )
CR ." 8|========7====||===6=====||==5=========4=========3=========2=========1========|"
CR ." 654321098765432109876543210987654321098765432109876543210987654321098765432109876543210987654321"
CR ." $===$===$===$===S===$===$===$===$===$===$===$===$===$===$===$===$===$= MSB <-- LSB =$===$===$==="
CR
;
: 96<>Ruler ( -- )
CR ." =========1=========2=========3=========4=========5=========6=========7=========8=========9======"
CR ." 123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456"
CR ." 654321098765432109876543210987654321098765432109876543210987654321098765432109876543210987654321"
CR ." ======9=========8=========7=========6=========5=========4=========3=========2=========1========="
CR
;
CREATE BitBUF 128 allot
: 32BitsDump ( un -- )
BitBUF 84 0 FILL
1 32
DO
0 2 UM/MOD SWAP
IF 49 BitBUF cappend ELSE 48 BitBUF cappend THEN
-1
+LOOP
DROP
BitBUF COUNT TURN
BitBUF COUNT TYPE
;
\ unBinaryDump
: unBDump ( un -- )
cr 32BitsDump 32cRuler
;
\ udBinaryDump
: udBDump ( ud -- )
cr 32BitsDump 32BitsDump 64cRuler
;
CREATE fpPAD B/FLOAT ALLOT
\ fpBinaryDump
: fpBDump ( f -- )
cr fpPAD F! fpPAD cell + @ 32BitsDump fpPAD @ 32BitsDump 64cRuler
;
((
: fpBDump ( f -- )
cr f>r 2r> swap 32BitsDump 32BitsDump 64cRuler
;
Warning(-4104): F>R is a *** deprecated *** word (see src\compat\evolve.f)
: F>R R> RP@ B/FLOAT - RP! RP@ F! >R ;
))
VARIABLE iTTT
$FFFFffff iTTT !
: TEST32 ( -- )
iTTT @ CR 32BitsDump 32cRuler
;
: addrBinaryDump ( addr -- )
cr DUP CELL + @ 32BitsDump @ 32BitsDump
;
\ 以上均為:於 8 B/FLOAT 時使用
: TEST64 ( -- )
sigdigits @
20 sigdigits !
$7fefFFFF fpPAD CELL + ! $ffffFFFF fpPad !
fpPAD CR addrBinaryDump 64cRuler
cr ." Maximum positive floating point number: " fpPAD f@ fs. cr
0 fpPAD cell + ! 1 fpPAD !
fpPAD cr addrBinaryDump 64cRuler
cr ." Minimum positive floating point number: " fpPAD f@ fs. cr
sigdigits !
;
\ 於 10 B/FLOAT 時使用
: TEST80 ( -- )
sigdigits @
20 sigdigits !
$7ffe fpPAD 2 CELLs + W! $ffffFFFF fpPad cell + ! $ffffFFFF fppad !
cr fpPAD 2 cells + W@ 32Bitsdump fpPad cell + @ 32bitsdump fppad @ 32bitsdump 96cRuler
cr ." Maximum positive floating point number: " fpPAD f@ fs. cr
0 fpPAD 2 cells + W! 0 fpPad cell + ! 1 fpPAD !
cr fpPAD 2 cells + W@ 32Bitsdump fpPad cell + @ 32bitsdump fppad @ 32bitsdump 96cRuler
cr ." Minimum positive floating point number: " fpPAD f@ fs. cr
sigdigits !
;
cr cr
.( Usage: ) cr
.( TEST32 TEST64 TEST80) cr
.( unBDump udBDump fpBDump 32BitsDump addrBinaryDump ) cr
\S
test64
0111111111101111111111111111111111111111111111111111111111111111
S|==6======||=5=========4=========3=========2=========1========|
4321098765432109876543210987654321098765432109876543210987654321
$===$===$===$===$===$===$===$===$===$= MSB <-- LSB =$===$===$===
Maximum positive floating point number: 1.7976931348623148800E308
0000000000000000000000000000000000000000000000000000000000000001
S|==6======||=5=========4=========3=========2=========1========|
4321098765432109876543210987654321098765432109876543210987654321
$===$===$===$===$===$===$===$===$===$= MSB <-- LSB =$===$===$===
Minimum positive floating point number: 4.9406564584124691200E-324
t41
Minnimum subnormal positive double floating point number
for 8 B/FLOAT 64 bits IEEE 754 =
4.940656458412465441765687928682213723650598026143
24764425585682500675507270208751865299836361635992
379796564656
X10^ -324
與系統印出數字比較如下:
最後三位數不準,因此,18位數只有15位數準確。20140519
4.9406564584124691200E-32
test80
000000000000000001111111111111101111111111111111111111111111111111111111111111111111111111111111
8|========7====||===6=====||==5=========4=========3=========2=========1========|
654321098765432109876543210987654321098765432109876543210987654321098765432109876543210987654321
$===$===$===$===S===$===$===$===$===$===$===$===$===$===$===$===$===$= MSB <-- LSB =$===$===$===
Maximum positive floating point number: 1.1897314953572317700E4932
000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
8|========7====||===6=====||==5=========4=========3=========2=========1========|
654321098765432109876543210987654321098765432109876543210987654321098765432109876543210987654321
$===$===$===$===S===$===$===$===$===$===$===$===$===$===$===$===$===$= MSB <-- LSB =$===$===$===
Minimum positive floating point number: 3.6451995318824745900E-4951
\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ (25-3)大型大數字顯示器.f ,可以顯示多於 256 位數的數字
\ 20140420
\ (1)起始設定最大容量為 40 cells ,最大顯示位數不會超過400位數
\ (2)起始設定值放在 TestValue
\ (3)顯示前,數值經由 >XRegister 搬到 XRegister
\ (4)顯示後 XRegister 的內容會被計算至 0
\ (5)被顯示的數字字串,放置在系統規劃指定的PAD1緩衝區內
\ (6)轉換出來的數字字串,顯示秩序原為顛倒,故需倒轉後才印出來
\ (7)延伸的應用為 TestValue 可以為任何數字,經 >XRegister 指令移入 XRegister
\ (8)固定執行指令 UX. 顯示數字。
40 VALUE NN
CREATE TestValue
\ $FFFFFFFF , 0 , 0 , 0 , 0 ,
$ffffffff , $ffffffff , $ffffffff , $ffffffff , $ffffffff ,
0 , 0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 , $f ,
CREATE XRegister NN Cells allot
1 CHARS CONSTANT /char ( -- n ) \ Length of a character
\ 改用cBigAppend及BigCount在PAD1區處理字串,其餘所用指令與一般大數顯示程式相同
\ : cAppend ( c s -- ) \ Add c to the counted string s
\ 1 OVER c+! COUNT 1- CHARS + C! ;
: cExchange ( ca1 ca2 -- ) \ Swap characters of ca1 and ca2
2DUP 2>R C@ SWAP C@ R> C! R> C! ;
: squeeze ( a1 a2 n -- a1+n a2-n ) \ Add/subtract n to/from a1/a2
TUCK - >R + R> ;
: turn ( ca u -- ) \ Reverse string ca u
1- CHARS OVER + ( start-addr end-addr )
BEGIN 2DUP U< WHILE 2DUP cexchange /char squeeze REPEAT 2DROP ;
: X/MODS ( n -- c ) \ ( n=Divisor=base@ -- c=RemainderChar )
0 \ n:Divisor=base@ 0:r=remainder
0 NN 1-
DO \ n r
XREGISTER I CELLS + @ \ n r q
SWAP \ = $100000000 r UM* q M+ ( n lq hr )
rot dup >r -rot r> \ n lq hr n
UM/MOD \ n r q ( ud u -- u' u" )
XREGISTER I CELLS + ! \ n r
-1
+LOOP \ n r
NIP \ r
9 OVER <
IF 7 + THEN
48 + \ r --> c
;
: ZeroCheck ( -- f )
-1
0 NN 1-
DO
XRegister I cells + @ 0= AND
-1 +LOOP
;
: (UX.) ( -- addr count ) ( addr:PAD1addr count:length )
PAD1 1024 0 FILL
BEGIN
BASE @ X/MODS PAD1 cBigAppend
ZeroCheck
UNTIL
PAD1 BigCount
2DUP TURN
;
: >XRegister ( addr -- )
XRegister NN cells MOVE ;
: UX. ( -- )
(UX.) BigType ;
: MAIN ( -- )
TestValue >XRegister
CR UX.
TypeCountingRuler
;
cr cr
.( Usage : main ) cr
\s
72698566559686319077796584419189618471650841510389 :50
26657279333344476955053168367802639659104216138961 :100
38203908732692781448693729442194346215678838077397 :150
82990628789152317139462189095909821299721140924092 :200
06005527971693100647871067150635851431673698774742 :250
70692250131011998411623056863545598788156045965681 :300
70016494590478505523789394870247171196184946947116 :350
842844713173773541038882815
=========1=========2=========3=========4=========5
12345678901234567890123456789012345678901234567890
========(c) 2014 Copyright, Counting Ruler========
ok
\ (26)數基名稱.f \ 20140501 Name of Various Number Bases \ Leo J. Scanlon, FORTH PROGRAMMING, Howard W. Sams & Co., Inc. 1982, p.157 DECIMAL \ : Binary 2 base ! ; : Ternary 3 base ! ; : Quatenary 4 base ! ; : Quinary 5 base ! ; : Senary 6 base ! ; : Septenary 7 base ! ; : Octonary 8 base ! ; \ : Octal 8 base ! ; : Novenary 9 base ! ; \ : Decimal 10 base ! ; : Undecimal 11 base ! ; : Duodecimal 12 base ! ; : Terdenary 13 base ! ; : Quaterdenary 14 base ! ; : Quindenary 15 base ! ; : Hexadecimal 16 base ! ; : Sexadecimal base ! ; : Septendecimal 17 base ! ; : Octodenary 18 base ! ; : Novemdenary 19 base ! ; : Vicenary 20 base ! ; : Duosexadecimal 32 base ! ; : Duotricinary 32 base ! ; : Sexagenary 60 base ! ;
\ (27)可令記憶體自動對準之指令.f
\ 20140501
: align1 ( n -- n' ) DUP 4 MOD ?DUP IF 4 SWAP - THEN + ; \ 4 錯,還令堆疊不定
: align2 ( n -- n' ) 1- 3 OR 1+ ; \ ok
: align3 ( n -- n' ) NEGATE -4 AND NEGATE ; \ ok
: align4 ( c-addr -- a-addr ) 3 + -4 and ; \ ok佳
: Align5 \ addr -- addr' ; \ 0 錯
%0011 and \ clear 2 lsbs
%0100 + \ next quad
;
: Align6 \ addr -- addr' ; \ 0 錯
$03 + \ force to next quad unless on boundary
%011 and \ clear 2 lsbs
;
\ : ALIGNED+ ( a -- n) 1- 1 cells 1- tuck and - ;
: aALIGNED+ ( a -- n) 1- 3 tuck and - ;
: aALIGNED ( a -- a) dup aaligned+ + ;
\ 對準技術問題的最佳方法就是:
\ 先將現行數目加上一數,令其進入下一群數目的範圍,對 cell=4 者而言為加上 cell-1=3。
\ 然後執行一次與等於負的對準量之 AND 運算,對 cell=4 者而言為與 -4 AND。
\ 於是就能得到合理的結果,以純 Forth 的表達方式寫成的程式形如下式:
: align7 ( a -- a' ) [ cell 1- ] literal + [ cell negate ] literal and ; \ ok
0 value tt
: test ( n -- )
to tt
cr ." test value = " tt .
cr ." align1 = " tt align1 . \ XXX
cr ." align2 = " tt align2 .
cr ." align3 = " tt align3 .
cr ." align4 = " tt align4 .
cr ." align5 = " tt align5 . \ XXX
cr ." align6 = " tt align6 . \ XXX
cr ." align7 = " tt align7 .
cr ." aligned = " tt aaligned .
;
\ 當系統進入 64 位元後,勢必再有必須與 8 對準之要求,根據上述設計推導如下
: align8 ( a -- a' )
7 + -8 and ;
\ (28)各種ROT設計範例.f \ 20140501 : ROT1 >r swap r> swap ; : ROT2 2 ROLL ; : ROT3 TUCK 2SWAP DROP ; : ROT4 over swap 2SWAP DROP ; \ NUP = over swap : ROT5 >R SWAP >R 2R> ; : ROT6 >R 2>R R> 2R> ; \ E.g., ROT using one register A: variable A : ROT7 >R >R A ! R> R> A @ ; : ROT8 A ! SWAP A @ SWAP ; \ E.g., ROT using two registers A and B: variable B : ROT9 A ! B ! >R B @ A @ R> ; 3 values t1 t2 t3 1 to t1 2 to t2 3 to t3 : .3t . . . ; : @3t t3 t2 t1 ; : pre cr @3t .3t @3t ; : aft ." ==> " .3t ; : main ( -- ) pre rot1 aft cr @3t .3t @3t rot2 ." ==> " .3t cr @3t .3t @3t rot3 ." ==> " .3t cr @3t .3t @3t rot4 ." ==> " .3t cr @3t .3t @3t rot5 ." ==> " .3t cr @3t .3t @3t rot6 ." ==> " .3t cr @3t .3t @3t rot7 ." ==> " .3t cr @3t .3t @3t rot8 ." ==> " .3t cr @3t .3t @3t rot1 ." ==> " .3t ;
\ (29)標準之多項式計算程式 2012-09-20
\ Polynomial equation
\ P(N)=A(0)+A(1)*X^1+A(2)*X^2+......+A(N)*X^N
3 INTEGERS I N N-1
2 REALS X P
10 ARRAY A
: SETUP-POLYNOMIAL-COEFFICIENTS
BASIC
10 REM (1)The degree of polynomial is N.
20 LET N = 4
30 REM (2)Set all coefficients in A(N) to be 0. N=0,1,2...n
40 FOR I = 0 TO N
50 LET { A ( I ) = 0 }
60 NEXT I
70 REM (3)Put all coefficients into A(N).
80 LET { A ( 0 ) = -5 }
:: { A ( 1 ) = 2 }
:: { A ( 2 ) = -1 }
:: { A ( 3 ) = 2 }
:: { A ( 4 ) = 3 }
90 END ;
: EVALUATING-POLYNOMIAL
BASIC
10 REM
20 REM Typical program
30 REM
40 LET { P = A ( N ) }
50 FOR I = 0 TO N - 1
60 LET N-1 = N - I - 1
70 LET { P = P * X + A ( N-1 ) }
80 NEXT I
90 END ;
: POOREVAL ( x -- p )
{{ X }} F!
{{ P = 3 * X ^ 4 + 2 * X ^ 3 - X ^ 2 + 2 * X - 5 }}
P ;
: SOSOEVAL ( x -- p )
{[ X }} F!
{{ P = 3 * X * X * X * X + 2 * X * X * X - X * X + 2 * X - 5 }}
P ;
: GOODEVAL ( x -- p )
{{ X }} F!
SETUP-POLYNOMIAL-COEFFICIENTS
EVALUATING-POLYNOMIAL
P ;
: main1
sigdigits @ >r
18 sigdigits ! cr cr
." POOREVAL P(pi)^4 = " fpi pooreval pooreval pooreval pooreval fs. cr cr
." SOSOEVAL P(pi)^4 = " fpi sosoeval sosoeval sosoeval sosoeval fs. cr cr
." GOODEVAL P(pi)^4 = " fpi goodeval goodeval goodeval goodeval fs. cr cr
r> sigdigits ! ;
main1
\ 多項式係數指標以反向表示時的計算程式
\ F(X)=A(0)*X^N+A(1)*X^(N-1)+........+A(N-1)*X^1+A(N)
\ 自動控制教科書中所使用的實際範例
\ Test for F(X)=X^4+15*X^3+270*X^2+1600*X+2000
: INIT1 BASIC
10 LET N = 4
20 LET { A ( 0 ) = 1 }
30 LET { A ( 1 ) = 15 }
40 LET { A ( 2 ) = 270 }
50 LET { A ( 3 ) = 1600 }
60 LET { A ( 4 ) = 2000 }
70 END ;
COMPLEX F(X) COMPLEX (X) REAL ABSF(X)
10 [ARRAY] ZA \ 將實數係數陣列轉換成複數係數陣列
3 INTEGERS II JJ NN \ 指標有不得再重覆使用於上列中者之困擾
: ZINIT BASIC
10 LET NN = N \ 方次與實數係數在算完之後均未變
20 FOR JJ = 0 TO NN \ 指標有不得再重覆使用於上列中者之困擾
30 LET [ ZA ( JJ ) = R>ZR ( A ( JJ ) ) ]
40 NEXT JJ
50 END ;
: FUNCTION(X) BASIC
10 RUN ZINIT
20 LET [ (X) = ( -3.5 - 2.4 i ) ]
30 LET [ F(X) = ZA ( 0 ) ]
40 FOR II = 1 TO NN \ 指標有不得再重覆使用於上列中者之困擾
50 LET [ F(X) = F(X) * (X) + ZA ( II ) ]
60 NEXT II
70 LET { ABSF(X) = ZABS ( F(X) ) }
80 END ;
\ 印出結果
: MAIN2 BASIC
10 FOR I = 1 TO N
20 RUN FUNCTION(X)
30 PRINT " F(X( " ; I ; " )) = " ; [ F(X) ]
40 PRINT " ABS(F(X( " ; I ; " )))=" ; { ABSF(X) }
50 PRINT " "
60 NEXT I
70 END ;
MAIN2
\S
POOREVAL P(pi)^4 = 3.20575403126800320E172
SOSOEVAL P(pi)^4 = 3.20575403126795584E172
GOODEVAL P(pi)^4 = 3.20575403126795584E172
F(X( 1 )) = 1225.31950000 - 1260.67200000 i
ABS(F(X( 1 )))= 1758.03918291
F(X( 2 )) = 1225.31950000 - 1260.67200000 i
ABS(F(X( 2 )))= 1758.03918291
F(X( 3 )) = 1225.31950000 - 1260.67200000 i
ABS(F(X( 3 )))= 1758.03918291
F(X( 4 )) = 1225.31950000 - 1260.67200000 i
ABS(F(X( 4 )))= 1758.03918291
ok
沒有留言:
張貼留言