一百個例題 (61 ~ 65)
Ching-Tang Tseng
Hamilton, New Zealand
22 September 2024
\ (61)Encrypte.f \ [---head---][lm|ln|---string---] : STRING ( lm -- ) CREATE 1 MAX MAXSTRING MIN DUP C, 0 C, ALLOT ( lm -- ) DOES> 1+ COUNT ; ( -- addr ln ) : S! ( addr1 cnt1 addr2 cnt2 -- ) DROP DUP 2 - C@ ROT MIN >R DUP 1- R@ SWAP C! R> CMOVE ; 80 STRING FILEPASSWORD \ password build here \ Usage: S" CTT20160310" FILEPASSWORD S! : EnterPassword ( -- ) CR ." Enter encrypte password : " CR QUERY 13 WORD COUNT FILEPASSWORD S! ; : EnterFileName ( -- ) CR ." Enter file name : " CR QUERY BL WORD COUNT GET-FILE ; : FILEENCRYPTE ( -- ) FLEN 0 DO I FADR + C@ I FILEPASSWORD NIP MOD FILEPASSWORD DROP + C@ XOR I FADR + C! LOOP ; : test ( -- ) EnterPassword EnterFileName CR CR FILETYPE FILEENCRYPTE CR CR FILETYPE FILEENCRYPTE CR CR FILETYPE ;
\ (62)Log2.f \ Lb(n) = Log2(n) , Lb(8)=3 means 8=2^3 \ ALb(n)= ALog2(n) = 2^n , ALb(3)=8 means 2^3=8 : Log2 ( n -- Log2[n] ) -1 SWAP BEGIN ?DUP WHILE SWAP 1+ SWAP 1 RSHIFT REPEAT ; : ALog2 ( n -- 2^n ) 1 SWAP 0 ?DO 2 * LOOP ;
\ (63)BackType.f \ 20160314 Hugh Aquilar posted on c.l.f. : backtype ( adr cnt -- ) over + 1- 2dup u< if do I c@ emit -1 +loop else 2drop then ; : $>pad ( adr cnt -- ) dup pad c! pad 1+ swap cmove ; s" this is a test." $>pad cr cr pad count type cr cr pad count backtype
\ (64)tone.f \ 20160402 \ 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 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 ; \s The following table shows the relationship of notes and their frequencies in one octave. _______________________________________________________ C D E F G A B Dl Re Mi Fa So La Si 261.63 293.66 329.63 349.23 392.00 440.00 493.88 523.25 587.33 659.26 698.46 783.99 880.00 987.77 ------------------------------------------------------- By doubling or halving the frequence, the coinciding note values can be estimated for the preceding and following octaves. \ (64-1)play music in wina forth : Z ( sc -- adr) 0 , DROP ; : 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-2)FasmForth64Tone.F \ REQUIRE API_2: lib\WAPI.4 \ REQUIRE API_2: WAPI.4 : DLL_CREATE CREATE PARSE-NAME FILE-BUFF ASCII-Z DLL_S DUP 0= ABORT" api unavailable" , ; : API_0: DLL_CREATE DOES> @ API_0 ; : API_1: DLL_CREATE DOES> @ API_1 NIP ; : API_2: DLL_CREATE DOES> @ API_2 NIP NIP ; : API_3: DLL_CREATE DOES> @ API_3 NIP NIP NIP ; : API_4: DLL_CREATE DOES> @ API_4 NIP NIP NIP NIP ; : API_5: DLL_CREATE DOES> @ API_5 NIP NIP NIP NIP NIP ; \ CR .( LIB LOAD=) S" KERNEL32.DLL" DROP DLL_L DUP H. \ DUP 0= [IF] .( KERNEL32.DLL LOAD ERROR) ABORT [THEN] S" KERNEL32.DLL" DROP DLL_L CONSTANT KERNEL32DLL \ Get API Beep KERNEL32DLL API_2: Beep Beep : sing ( duration freqency -- ) Beep DROP ;
: tone ( time frequency -- ) CALL Beep drop ; \ morse demonstation begins here 880 constant freq \ 440 --> 880, value --> constant 45 constant adit \ 1 dit will be 45 ms, value --> constant : ns 4 * ; \ convert adit to duration value, without nano second meaning : dit_dur adit ns ; : dah_dur adit 3 * ns ; : wordgap adit 5 * ns ; : off_dur adit 2/ ns ; : lettergap dah_dur ; : sound ( duration -- ) freq tone ; : silence ( duration -- ) 0 tone ; : MORSE-EMIT ( char -- ) \ send morse and echo to console dup bl = \ bl = blank = 32 if wordgap silence drop else PAD C! \ write char to buffer PAD 1 EVALUATE \ evaluate 1 character lettergap silence \ pause for correct sounding morse code then ; : BOUNDS ( ADDR LEN -- Last Init ) OVER + SWAP ; : TRANSMIT ( ADDR LEN -- ) CR \ newline, BOUNDS \ convert loop indices to address ranges DO I C@ dup emit \ dup and send char to console MORSE-EMIT \ send the morse code LOOP ; : . ( -- ) dit_dur sound off_dur silence ; : - ( -- ) dah_dur sound off_dur silence ; \ define morse letters as Forth words. They transmit when executed : A . - ; : B - . . . ; : C - . - . ; : D - . . ; : E . ; : F . . - . ; : G - - . ; : H . . . . ; : I . . ; : J . - - - ; : K . - . ; : L . - . . ; : M - - ; : N - . ; : O - - - ; : P . - - . ; : Q - - . - ; : R . - . ; : S . . . ; : T - ; : U . . - ; : V . . . - ; : W . - - ; : X - . . - ; : Y - . - - ; : Z - - . . ; : 0 - - - - - ; : 1 . - - - - ; : 2 . . - - - ; : 3 . . . - - ; : 4 . . . . - ; : 5 . . . . . ; : 6 - . . . . ; : 7 - - . . . ; : 8 - - - . . ; : 9 - - - - . ; : ' - . . - . ; : \ . - - - . ; : ! . - . - . ; : ? . . - - . . ; : , - - . . - - ; : / . . . - . - ; ( SK means end of transmission in int'l Morse code) : . . - . - . - ; S" CQ CQ CQ DE VE3CFW VE3CFW / " TRANSMIT
沒有留言:
張貼留言