aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Initial data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 72d218235f
commit f23f22d71c
199087 changed files with 3378941 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

84
Task/Morse-code/Forth/morse-code.fth Normal file
View file

@ -0,0 +1,84 @@
HEX
\ PC speaker hardware control (requires GIVEIO or DOSBOX for windows operation)
042 constant fctrl
043 constant tctrl
061 constant sctrl
0FC constant smask
\ PC@ is Port char fetch (Intel IN instruction). PC! is port char store (Intel OUT instruction)
: speak ( -- ) sctrl pc@ 03 or sctrl pc! ;
: silence ( -- ) sctrl pc@ smask and 01 or sctrl pc! ;
: tone ( freq -- ) \ freq is actually just a divisor value
?dup \ check for non-zero input
if 0B6 tctrl pc! \ enable PC speaker
dup fctrl pc! \ set freq
8 rshift fctrl pc!
speak
else
silence
then ;
\ morse demonstration begins here
DECIMAL
1000 value freq \ arbitrary value that sounded ok
90 value adit \ 1 dit will be 90 ms
: dit_dur adit ms ;
: dah_dur adit 3 * ms ;
: wordgap adit 5 * ms ;
: off_dur adit 2/ ms ;
: lettergap dah_dur ;
: sound ( -- ) freq tone ;
: MORSE-EMIT ( char -- )
dup bl = \ check for space character
if
wordgap drop \ and delay if detected
else
pad C! \ write char to buffer
pad 1 evaluate \ evaluate 1 character
lettergap \ pause for correct sounding morse code
then ;
: 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 ;
VOCABULARY MORSE \ prevent name conflicts with letters and numbers
MORSE DEFINITIONS \ the following definitions go into MORSE namespace
: . ( -- ) sound dit_dur silence off_dur ;
: - ( -- ) sound dah_dur silence off_dur ;
\ 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 - - - - . ;
: ' - . . - . ;
: \ . - - - . ;
: ! . - . - . ;
: ? . . - - . . ;
: , - - . . - - ;
: / - . . - . ;
: . . - . - . - ;
PREVIOUS DEFINITIONS \ go back to previous namespace
: TRANSMIT MORSE TRANSMIT PREVIOUS ;