一百個例題 (76 ~ 80)
Ching-Tang Tseng
Hamilton, New Zealand
1 October 2024
\ (76)BisecFsqrt.f variable count \ full forth style fvariable n fvariable a fvariable b fvariable p : test ( f -- fsqrt ) 0 count ! fdup n f! a f! 0.0 E 0 b f! begin a f@ b f@ f- fabs 1. e -14 f> \ 以10Bytes/Float來算,設定便可以改為1.e-18,就與系統計算結果完全一致, \ 否則只能用1.e-14。 while a f@ b f@ f+ 2.0 e 0 f/ p f! a f@ fdup F* n f@ f- \ f(a)=a*a-n fdup f0= if fdrop a f@ exit then p f@ fdup f* n f@ f- \ f(p)=p*p-n fdup f0= if fdrop p f@ exit then f* f0> if p f@ a f! else p f@ b f! then 1 count +! repeat a f@ b f@ f+ 2. e 0 f/ dup -16 < if fround then ; \ 18 sigdigits ! : main 101 1 do cr i . ." count = " count @ . cr i . ." fsqrt = " i s>f fsqrt fs. cr i . ." bfsqrt = " i s>f test fs. loop ; main \s (( 9 reals n a b p fa fb fp eps ft : test1 ( f -- fsqrt ) 0 count ! fdup {{ n }} f! {{ a }} f! 0.E0 {{ b }} f! begin {{ fa = a * a - n }} {{ fb = b * b - n }} {{ eps = abs ( a - b ) - 1.E-15 }} eps f0> while {{ p = ( a + b ) / 2 }} {{ fp = p * p - n }} {{ ft = fa * fp }} ft f0> A if {{ a = p }} else {{ b = p }} then 1 count +! repeat cr ." count = " count @ . cr ." fsqrt1 = " {{ ft = ( a + b ) / 2 }} ft fs. cr ." fsqrt2 = " n fsqrt fs. ; \ need only n a b p ft : test2 0 count ! fdup {{ n }} f! {{ a }} f! 0.E0 {{ b }} f! begin {{ ft = abs ( a - b ) - 1.E-15 }} ft f0> while {{ p = ( a + b ) / 2 }} {{ ft = ( ( a * a ) - n ) * ( ( p * p ) - n ) }} ft f0> if {{ a = p }} else {{ b = p }} then 1 count +! repeat cr ." count = " count @ . cr ." fsqrt1 = " {{ ft = ( a + b ) / 2 }} ft fs. cr ." fsqrt2 = " n fsqrt fs. ; \ need only n a b p : test3 0 count ! fdup {{ n }} f! {{ a }} f! 0.E0 {{ b }} f! begin a b f- fabs 1.e-15 f> while {{ p = ( a + b ) / 2 }} a a F* n f- p p f* n f- f* f0> if {{ a = p }} else {{ b = p }} then 1 count +! repeat cr ." count = " count @ . cr ." fsqrt1 = " a b f+ 2.e0 f/ fs. cr ." fsqrt2 = " n fsqrt fs. ; ))
\ (77)hat.f \ Make an exclusive local array beside a word : hat ( n -- addr ) current @ swap cells - ; \ Usage and test demo \ Integer: compute 3*n1*n1+10*n1-7*n2 2 cells allot : test ( n1 n2 -- ) \ n2 to 2 hat n1 to 1 hat 2 hat ! 1 hat ! 3 1 hat @ dup * * dup cr . 10 1 hat @ * + dup cr . 7 2 hat @ * - cr . ; 1 cells allot : test2 ( n1 -- n2 ) 1 hat ! 1 hat @ dup * 2 * 1 hat @ -5 * - 10 + cr . ; \ Floatiing point: compute torque according to power and rotating speed \ ª«²zžÑµª p.183 , torque = hp / rpm \ 2 cells/fp 8 cells allot : torque ( hp rpm -- ) 6 hat f! 3 hat f! \ rpm to 4 hat, hp to 2 hat 3 hat f@ 550.e0 f* \ hp --> ft-lb/sec 6 hat f@ 2.e0 fpi f* f* 60.e0 f/ \ rpm --> rad/sec f/ cr ." torque = " fs. space ." lb-ft " ; 4 cells allot : torque2 ( hp rpm -- ) 550.e0 3 hat f! \ convert factore to 2 hat 2.e0 fpi F* f* 60.e0 f/ \ rpm --> rad/sec fswap 3 hat f@ f* fswap f/ cr ." torque = " fs. space ." lb-ft " ; \S \ for wina32 and lina64 \ (6). hat, fpi \ ************************************** \ Make an exclusive local array beside a word : hat ( n -- addr ) current @ >nfa @ swap 1+ cells - ; \ testing started from this point \ 1 cells allot \ : tt1 ( n -- ) \ 1 hat ! 10 30 * 5 + 1 hat @ /mod \ cr ." This is tt1." 3 spaces . . ; \ : tt2 ( -- ) \ cr ." This is tt2." ; \ : tt3 ( -- ) \ cr ." This is tt3." ; \ 2 cells allot \ : tt4 ( n1 n2 -- ) \ 2 hat ! 1 hat ! \ 10 1 hat @ * 2 hat @ + \ cr ." This is tt4." 3 spaces . ; \ 2+1-->3, 5+1-->6, 3 cells/fp \ 6 cells allot \ : tt5 ( r1 r2 -- ) \ 5 hat f! \ 2 hat f! \ 2 hat f@ 1.0 E 0 f* \ 5 hat f@ 3.0 E 0 f* \ f+ cr fs. ; 3.14159265358979328 E 0 fconstant fpi \ 6 cells allot \ : tt6 ( hp rpm -- ) \ 5 hat f! 2 hat f! \ rpm to 5 hat, hp to 2 hat \ 2 hat f@ 550. E 0 f* \ hp --> ft-lb/sec \ 5 hat f@ fpi fdup f+ f* 60. E 0 f/ \ rpm --> rad/sec \ f/ \ cr ." torque = " fs. space ." lb-ft " ; \ 3 cells allot \ : tt7 ( r -- ) \ 2 hat f! \ 10. E 0 fdup f* \ 2 hat f@ \ f/ cr fs. ; \ testing finished here \ ************************************** \ for gforth64 \ : hat ( n -- addr ) \ current @ >body swap 3 + cells - ; \ 3 cells allot \ : tt8 ( -- ) \ 1 1 hat ! 2 2 hat ! 3 3 hat ! \ 1 hat @ 2 hat @ + \ 3 hat @ + \ cr . ; \ execute tt8 get 6
\ (78) long dot /.. : (u.) ( u -- addr len ) 0 <# #s #> ; \ Maximum digits great than 253 characters. variable MaxDigits 400 MaxDigits ! : pad1 ( -- addr ) HERE 1024 + ; \ Big counted string at addr1 : BigCount ( addr1 -- addr2 len ) dup cell + swap @ ; \ Add string addr1 cnt to the big counted string addr2 : BigAppend ( addr1 len addr2 -- ) 2DUP 2>R BigCount CHARS + SWAP CMOVE 2R> DUP >R @ + R> ! ; \ Add one char to the big counted string addr : cBigAppend ( c addr -- ) dup >r BigCount + c! r@ @ 1+ r> ! ; : (/..) ( Numerator Denominator -- addr len ) dup 0= abort" Warning: /0 error! " pad1 256 0 fill 2dup 0< swap 0< xor 0< if 45 pad1 cBigAppend then \ - abs >r abs r> swap over /mod (u.) pad1 BigAppend \ integer part 46 pad1 cBigAppend \ . MaxDigits @ 1- 0 \ fraction part do over >r 10 um* r> um/mod (u.) pad1 BigAppend dup 0= if leave then loop 2drop pad1 BigCount ; variable 50c/l : RightSideMark ( -- ) 3 SPACES ." :" 50 50c/l +! base @ decimal 50c/l @ . base ! CR ; : BigTypeWithRightSideMark ( addr len -- ) 0 50c/l ! >r begin r@ 50 > while dup 50 type RightSideMark r> 50 - >r 50 + repeat r> type ; : 50cRuler ( -- ) cr ." =========1=========2=========3=========4=========5" cr ." 12345678901234567890123456789012345678901234567890" cr ." ========(c) 2014 Copyright, 50 chars Ruler========" cr ; : /.. ( Numerator Denominator -- ) (/..) cr BigTypeWithRightSideMark 50cRuler ;
\ (79) Double precision integer arithmetic. \ Revamped for ciforth from Dr. Tim Hendtlass, Real Time Forth, Swinburne University of Technology, 1993, P.62 \ 20170317 \ Multiply two double precision numbers to give a double precision product. : d- dnegate d+ ; \ : PICK 1+ CELLS DSP@ + @ ; \ : ?dnegate 0< if dnegate then ; \ With overflow check. : UD*C ( ud1 ud2 -- ud3 ) \ all numbers unsigned doubles dup >r rot dup >r >r over >r \ put a c c b on return stack >r swap dup >r \ put a d onto return stack um* \ b*d 0 r> r> um* d+ r> r> um* d+ \ offset 16 bits, add on a*d+b*c 0 r> r> um* d+ \ offset another 16 bits, add on a*c or 0<> abort" D* overflow" \ check for overflow ; \ Without overflow check. : UD* ( ud1 ud2 -- ud3 ) \ all numbers unsigned doubles rot >r over >r >r over >r \ put c b a d on return stack um* \ b*d = part of 32 bit answer r> r> * r> r> * + + \ a*d+b*c= addition to top 16 bits ; : D* ( d1 d2 -- d3 ) \ all numbers signed doubles dup >r dabs 2swap dup >r dabs \ #s +ve, keep info to work out final sign ud* \ get 32 bit answer. Change this to ud*c to get overflow c heck r> r> xor 0< if dnegate then \ r> r> xor ?dnegate \ work out and apply final sign ; \ More clear D* \ : D* ( d1 d2 -- d3 ) \ >r >r \ over r@ um* \ rot r> * + \ rot r> * + ; \ Division - ( U0 * 216 +U1 ) / (V0 * 216 + V1 ) = (A0 * 216 + A1 ) \ Use fast algorithm, remainder needs an additional 32 bit multiplication and subtraction. : T* ( ud un -- ut ) \ Unsigned double * unsigned single = unsigned triple dup rot um* >r >r \ high-part of answer to return stack um* 0 r> r> d+ \ get low-part,offset 16 bits,add high-part ; : T/ ( ut un -- ud ) \ Unsigned triple / unsigned single = unsigned double >r r@ um/mod swap \ divisor > r, divide top 16 bits, rem to top rot 0 r@ um/mod swap \ combine with next 16, divide these by divisor rot r> um/mod swap drop \ repeat for last 16 bits, lose final remainder 0 2swap swap d+ \ combine parts of answer to for final answer ; : U*/ ( ud un1 un2 -- ud2 ) \ ud * un1 / un2, triple intermediate product >r t* r> t/ ; : UD/ ( U1 U0 V1 V0 -- A1 A0) \ Unsigned 32 bit by 32 bit divide. No remainder dup 0= \ top 16 bits of divisor = 0? if swap t/ \ simple case, make it a triple, do / else \ more involved case dup 0 1 rot 1+ um/mod >r \ work out scaling factor,copy to r. (I did 65536. ==> 0 1) drop r@ t* drop >r >r \ scale denominator, move to return stack dup 0 r> r> 2dup >r >r u*/ d- \ calculate (U-U0*W1/W0) r> r> r> -rot nip u*/ \ multiply by (D/W0) nip 0 \ /2^16, make answer double then ; : D/MOD ( dn1 dn2 -- drem dquot ) \ Divide two signed double numbers 2 pick over xor >r \ work out sign of answer dabs 2swap dabs 2swap \ convert numbers to positive 2over 2over ud/ 2dup >r >r \ do the division, save copy of quotient ud* d- \ calculate the remainder r> r> r> 0< if dnegate then \ r> ?dnegate \ retrieve answer,apply final sign ; : D/ ( dn1 dn2 -- dquot ) \ Divide two signed doubles, no remainder 2 pick over xor >r \ work out sign of answer dabs 2swap dabs 2swap \ convert numbers to positive ud/ \ do the division r> 0< if dnegate then \ r> ?dnegate \ retrieve answer, apply final sign ;
\ (80-1)play music in wina forth : make-constant ( n adr -- ) BODY> >R R@ >DFA ! 'BL >CFA @ R> >CFA ! ; : LOAD-DLL: ( sc -- u ) CREATE $, DROP DOES> DUP >R $@ LOAD-DLL DUP R> make-constant ; : DLL-ADDRESS: ( sc xt -- adr ) CREATE , $, DROP DOES> DUP >R CELL+ $@ R@ @ EXECUTE DLL-ADDRESS DUP R> make-constant ; "kernel32.dll" LOAD-DLL: K32 "Beep" 'k32 DLL-ADDRESS: BBB : sing ( time frequency -- ) BBB call drop ; \ (64)tone.f \ 20160402 \ 基本原理只利用給音長及音頻後叫用Beep功能程式便可唱出單音來 \ 試用後效果顯示在XP環境中尚可,在W7環境中尾音被切除得很清楚,效果變差。 \ 選用192此值,係因可作為拍子設定之最小公倍數使用,以便都能除得整數。 \ 192 = 2*3*4*8 192 3 * VALUE Duration \ n1:Duration n2:Tone Frequency \ : sing ( n1 n2 -- ) CALL Beep drop ; : silence ( n1 -- ) MS ; : | ; immediate \ Get duration ( -- n1 ) : 4T Duration 4 * ; : 3T Duration 3 * ; : 2T Duration 2 * ; : 1T Duration ; : T/2 Duration 2 / ; : T/3 Duration 3 / ; : T/4 Duration 4 / ; : T/8 Duration 8 / ; : T/16 Duration 16 / ; \ Get tone frequency ( -- n2 ) \ 全面降八度時用,注意!每八度均成整數倍的關係。 \ : MDO 262 ; \ : MRE 294 ; \ : MMI 330 ; \ : MFA 349 ; \ : MSO 392 ; \ : MLA 440 ; \ : MSI 494 ; : MDO 523 ; : MRE 587 ; : MMI 659 ; : MFA 698 ; : MSO 784 ; : MLA 880 ; : MSI 988 ; \ Sing it ( n1 -- ) : Dl MDo sing ; : LDo MDo 2 / sing ; : HDo MDo 2 * sing ; : Re MRe sing ; : LRe MRe 2 / sing ; : HRe MRe 2 * sing ; : Mi MMi sing ; : LMi MMi 2 / sing ; : HMi MMi 2 * sing ; : Fa MFa sing ; : LFa MFa 2 / sing ; : HFa MFa 2 * sing ; : So MSo sing ; : LSo MSo 2 / sing ; : HSo MSo 2 * sing ; : La MLa sing ; : LLa MLa 2 / sing ; : HLa MLa 2 * sing ; : Si MSi sing ; : LSi MSi 2 / sing ; : HSi MSi 2 * sing ; : Waltzing-Matilda 1T SO T/2 SO T/2 SO 1T SO 1T MI 1T HDO T/2 HDO T/2 SI 1T LA 1T SO 1T SO T/2 SO T/2 SO 1T LA 1T SO 1T SO T/2 FA T/2 MI 1T RE T/2 Dl T/2 RE 1T MI 1T MI 1T RE 1T RE T/2 Dl T/2 RE T/2 MI T/2 Dl T/2 LLA T/2 LSI 1T Dl 1T LSO T/2 Dl T/2 MI 1T SO T/2 FA T/2 MI 1T RE T/2 RE T/2 RE 1T Dl ; : Jasmine 1T MI T/2 MI T/2 SO T/2 LA T/2 HDO T/2 HDO T/2 LA 1T SO T/2 SO T/2 LA 2T SO 1T MI T/2 MI T/2 SO T/2 LA T/2 HDO T/2 HDO T/2 LA 1T SO T/2 SO T/2 LA 2T SO 1T SO 1T SO 1T SO T/2 MI T/2 SO 1T LA 1T LA 2T SO 1T MI T/2 RE T/2 MI 1T SO T/2 MI T/2 RE 1T Dl T/2 Dl T/2 RE 2T Dl T/2 MI T/2 RE T/2 Dl T/2 MI 1T T/2 + RE T/2 MI 1T SO T/2 LA T/2 HDO 2T SO 1T RE T/2 MI T/2 SO T/2 RE T/2 MI T/2 Dl T/2 LLA 2T LSO 1T LLA 1T Dl 1T T/2 + RE T/2 MI T/2 Dl T/2 RE T/2 Dl T/2 LLA 2T LSO ; : I-am-a-little-bird 1T DL 1T DL 1T DL 1T T/2 + MI T/2 RE 1T DL 1T MI 1T MI 1T MI 1T T/2 + SO T/2 FA 1T MI 1T SO 1T FA 1T MI 3T RE 2T RE T/2 DL T/2 SI 1T DL 1T RE 1T MI 2T FA T/2 MI T/2 RE 1T MI 1T FA 1T SO T/2 SO T/2 FA 1T MI 1T RE 2T DL ; : Pocalicalina 1T SO T/2 HMI T/2 HMI T/2 HRE T/2 HRE 2T HDO 3T HMI ; : TEST 1 0 DO Waltzing-Matilda 2T silence Pocalicalina 2T silence Jasmine 2T silence I-am-a-little-bird 2T silence LOOP ;
沒有留言:
張貼留言