一百個例題 (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
沒有留言:
張貼留言