API tools faq
paste
Guest User

Morse trainer in Forth

a guest
Mar 5th, 2024
25
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 36.70 KB | Source Code | 0 0
raw download clone embed print report
  1.  
  2. Morse trainer
  3.  
  4. empty forth definitions decimal application
  5. warning on
  6.  
  7. : TITLE ." MORSE version 1.31 2021-07-16" cr ;
  8.  
  9. cr .( Compiling: ) title 2 load
  10.  
  11. cr .( Save to disk? ) y/n [if]
  12. \ tally @ pad + #256 + limit s0 @ - + set-limit
  13. turnkey program MORSE
  14. [then]
  15.  
  16. variable TALLY 0 tally ! \ run-time memory tally
  17. defer ?STOP ' noop is ?stop \ user abort check
  18. defer CON-IO ' bios-io is con-io \ default console i/o mode
  19. defer ONERROR ' noop is onerror \ reset on-error handler
  20. defer ONSTART ' noop is onstart \ startup initialization
  21.  
  22. blk @ 1+ #screens 1- thru \ load electives & application
  23.  
  24. ' ?stopkey is ?stop \ enable user abort
  25. \ ' dos-io is con-io \ enable console redirection
  26. \ ' deloutfile +is onerror \ delete outfile on error
  27. \ wrtchk off \ disable overwrite check
  28.  
  29. 1 fload DOSLIB \ DOSLIB library
  30. _Errors \ error handler
  31. \ _Inout1 \ number output
  32. \ _Inout2 \ number output
  33. \ _Inout3 \ deferred output
  34. \ _Compare1 \ basic compare
  35. _String1 \ basic strings
  36. \ _String2 \ extra strings
  37. _Parsing1 \ command-line parsing
  38. _Parsing2 \ command-line parsing
  39. _Fileprims \ file primitives
  40. _Files \ default files
  41. \ _Bufinfile \ buffered input file
  42. _Bufoutfile \ buffered output file
  43.  
  44. _Random \ random numbers
  45. \ _Shuffle \ shuffle cells
  46. \ _Qsort \ quicksort cells
  47. \ _Dos1 \ dta
  48. \ _Dos2 \ ctl-brk int
  49. \ _Disk \ disk
  50. \ _Memory \ memory allocate
  51. \ _Timedate1 \ time/date
  52. \ _Timedate2 \ time/date
  53. \ _Timepack \ time/date packing
  54. \ _Filematch \ file find first/next
  55. \ _Wildexp \ file wildcard expander
  56. \ _Filestamp \ file stamp/attribute
  57. \ _Diskdir \ directory
  58.  
  59. \ _Env \ environment
  60. \ _Exec \ exec prog/command
  61. \ _Video1 \ textcolor attrib cursor
  62. \ _Video2 \ mode page
  63. \ _Timing1 \ timer
  64. \ _Timing2 \ delay
  65. \ _Timing3 \ ticker mode
  66. \ _Device1 \ 8087 cpu keybd
  67.  
  68. : HELP ( -- ) dos-io cr cr title
  69. cr ." Use: MORSE [-opt] txtfile[.TXT] [sndfile]" cr
  70. cr ." -S|Cn send/character speed WPM 5-40"
  71. cr ." -Dw,c word/char spacing Dits 2 min"
  72. cr ." -Tn tone Hz 400-1000"
  73. cr ." -Pn punctuation 0=none 1=basic 2=full"
  74. cr ." -O space compression off"
  75. cr ." -W|V[n] output to WAV/VOC file [voice 0-2]"
  76. cr ." -Un WAV/VOC volume 0-9"
  77. cr ." -G[n] generate random groups [Koch chars 2-40]"
  78. cr ." -Rccc generate random groups using chars ccc"
  79. cr ." -Fc,r,s random group format: cols,rows,size"
  80. cr ." -I ignore option settings in textfile"
  81. cr ." -L insert line start/end signals \\CT \\AR"
  82. cr ." -H hide screen output"
  83.  
  84. cr
  85. cr ." default: send file, spaces compressed, no punctuation"
  86. cr
  87. cr ." Morse code trainer. Send text file as morse code"
  88. cr ." to PC speaker or WAV/VOC sound file. Create custom"
  89. cr ." groups of random characters."
  90. con-io abort ;
  91.  
  92. \ Add single to double variable
  93. : M+! ( n addr -- ) dup >r 2@ rot m+ r> 2! ;
  94.  
  95. \ Shuffle characters
  96. : SHUFFLE ( adr len -- )
  97. 1 swap do
  98. dup i random chars +
  99. 2dup c@ swap c@
  100. rot c! over c!
  101. char+
  102. -1 +loop drop ;
  103.  
  104. variable CHAR.S \ character speed
  105. variable SEND.S \ send speed
  106. variable WSPACE \ word spacing in Dits
  107. variable CSPACE \ char spacing in Dits
  108. variable COMPRESS \ space compression
  109. variable GROUPCOLS \ random group columns
  110. variable GROUPROWS \ random group lines
  111. variable GROUPSIZE \ random group size
  112. variable IGNORE \ ignore option field
  113. variable LASTCHAR \ last character processed
  114. variable TRAIN \ mode 0=generate
  115. variable PUNCT \ punctuation
  116. variable RNDTXT \ random or plain text
  117. variable TONE \ audio frequency
  118.  
  119. variable SHAPING \ flag for MQUIET
  120. variable SPACING \ flag for __ (space)
  121.  
  122. 2variable WAVESIZ \ wavefile data size
  123. 2variable RATIO \ wavefile loops/msec ratio
  124. 2variable LINE \ input line pointer
  125.  
  126. 0 value OUTDEV \ 0=TXT/SPKR 1=WAV 2=VOC
  127. 0 value D_ELEMENTS \ standard word dit elements
  128. 0 value S_ELEMENTS \ standard word space elements
  129. 0 value #BASIC \ basic character set
  130. 0 value #PUNCT \ including punctuation
  131. 0 value #EXTENDED \ including extended
  132. 0 value #CONTROLS \ ARRL control characters
  133.  
  134. 5 40 2constant SPEEDRANGE \ min/max speed
  135.  
  136. 132 constant LINEMAX \ max text line length
  137. create LBUF linemax 2+ allot \ line buffer
  138.  
  139. 11025 constant BITRATE \ wavfile bits/sec
  140. 60 constant #PCMHDR \ PCM header bytes to strip
  141.  
  142. variable KOCH \ Koch characters (2-40)
  143. 0 value #KOCH \ Koch character set count
  144.  
  145. variable LSIGNAL \ line start/end signals
  146. variable WHITESPACE \ line is whitespace or empty
  147.  
  148. 2000 constant GMAX \ max random group
  149. 0 value GBUF \ random group buffer addr
  150. 0 value GSIZE \ & size
  151.  
  152. $1A constant EOF \ End-of-file character
  153. 0 value HIDE \ hide screen output
  154.  
  155. variable VOLUME \ volume
  156.  
  157. \ Conditionally output text
  158. : ?EMIT ( c -- ) hide if drop end emit ;
  159. : ?TYPE ( a u -- ) hide if 2drop end type ;
  160. : ?CR ( -- ) hide if end cr ;
  161.  
  162. hex
  163. here ( 1 cycle - sine)
  164. 80 c, 80 c, 81 c, 83 c, 85 c, 85 c, 87 c, 89 c,
  165. 8B c, 8D c, 8D c, 8F c, 91 c, 93 c, 93 c, 95 c,
  166. 97 c, 99 c, 9A c, 9A c, 9C c, 9E c, 0A0 c, 0A0 c,
  167. 0A2 c, 0A4 c, 0A6 c, 0A6 c, 0A8 c, 0AA c, 0AC c, 0AC c,
  168. 0AE c, 0B0 c, 0B0 c, 0B2 c, 0B3 c, 0B5 c, 0B5 c, 0B7 c,
  169. 0B9 c, 0B9 c, 0BB c, 0BD c, 0BD c, 0BF c, 0C1 c, 0C1 c,
  170. 0C3 c, 0C5 c, 0C5 c, 0C7 c, 0C9 c, 0C9 c, 0CB c, 0CB c,
  171. 0CC c, 0CE c, 0CE c, 0D0 c, 0D0 c, 0D2 c, 0D4 c, 0D4 c,
  172. 0D6 c, 0D6 c, 0D8 c, 0D8 c, 0DA c, 0DA c, 0DC c, 0DC c,
  173. 0DE c, 0DE c, 0E0 c, 0E0 c, 0E2 c, 0E2 c, 0E4 c, 0E4 c,
  174. 0E5 c, 0E5 c, 0E7 c, 0E7 c, 0E7 c, 0E9 c, 0E9 c, 0EB c,
  175. 0EB c, 0EB c, 0ED c, 0ED c, 0ED c, 0EF c, 0EF c, 0EF c,
  176.  
  177. 0F1 c, 0F1 c, 0F1 c, 0F1 c, 0F3 c, 0F3 c, 0F3 c, 0F5 c,
  178. 0F5 c, 0F5 c, 0F5 c, 0F5 c, 0F7 c, 0F7 c, 0F7 c, 0F7 c,
  179. 0F7 c, 0F7 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c,
  180. 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c,
  181. 0FB c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c,
  182. 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F9 c, 0F7 c,
  183. 0F7 c, 0F7 c, 0F7 c, 0F7 c, 0F7 c, 0F5 c, 0F5 c, 0F5 c,
  184. 0F5 c, 0F5 c, 0F3 c, 0F3 c, 0F3 c, 0F1 c, 0F1 c, 0F1 c,
  185. 0F1 c, 0EF c, 0EF c, 0EF c, 0ED c, 0ED c, 0ED c, 0EB c,
  186. 0EB c, 0EB c, 0E9 c, 0E9 c, 0E7 c, 0E7 c, 0E7 c, 0E5 c,
  187. 0E5 c, 0E4 c, 0E4 c, 0E2 c, 0E2 c, 0E0 c, 0E0 c, 0DE c,
  188. 0DE c, 0DC c, 0DC c, 0DA c, 0DA c, 0D8 c, 0D8 c, 0D6 c,
  189. 0D6 c, 0D4 c, 0D4 c, 0D2 c, 0D0 c, 0D0 c, 0CE c, 0CE c,
  190. 0CC c, 0CB c, 0CB c, 0C9 c, 0C9 c, 0C7 c, 0C5 c, 0C5 c,
  191.  
  192. 0C3 c, 0C1 c, 0C1 c, 0BF c, 0BD c, 0BD c, 0BB c, 0B9 c,
  193. 0B9 c, 0B7 c, 0B5 c, 0B5 c, 0B3 c, 0B2 c, 0B0 c, 0B0 c,
  194. 0AE c, 0AC c, 0AC c, 0AA c, 0A8 c, 0A6 c, 0A6 c, 0A4 c,
  195. 0A2 c, 0A0 c, 0A0 c, 9E c, 9C c, 9A c, 9A c, 99 c,
  196. 97 c, 95 c, 93 c, 93 c, 91 c, 8F c, 8D c, 8D c,
  197. 8B c, 89 c, 87 c, 85 c, 85 c, 83 c, 81 c, 80 c,
  198. 80 c, 80 c, 7F c, 7D c, 7B c, 7B c, 79 c, 77 c,
  199. 75 c, 73 c, 73 c, 71 c, 6F c, 6D c, 6D c, 6B c,
  200. 69 c, 67 c, 66 c, 66 c, 64 c, 62 c, 60 c, 60 c,
  201. 5E c, 5C c, 5A c, 5A c, 58 c, 56 c, 54 c, 54 c,
  202. 52 c, 50 c, 50 c, 4E c, 4D c, 4B c, 4B c, 49 c,
  203. 47 c, 47 c, 45 c, 43 c, 43 c, 41 c, 3F c, 3F c,
  204. 3D c, 3B c, 3B c, 39 c, 37 c, 37 c, 35 c, 35 c,
  205. 34 c, 32 c, 32 c, 30 c, 30 c, 2E c, 2C c, 2C c,
  206.  
  207. 2A c, 2A c, 28 c, 28 c, 26 c, 26 c, 24 c, 24 c,
  208. 22 c, 22 c, 20 c, 20 c, 1E c, 1E c, 1C c, 1C c,
  209. 1B c, 1B c, 19 c, 19 c, 19 c, 17 c, 17 c, 15 c,
  210. 15 c, 15 c, 13 c, 13 c, 13 c, 11 c, 11 c, 11 c,
  211. 0F c, 0F c, 0F c, 0F c, 0D c, 0D c, 0D c, 0B c,
  212. 0B c, 0B c, 0B c, 0B c, 09 c, 09 c, 09 c, 09 c,
  213. 09 c, 09 c, 07 c, 07 c, 07 c, 07 c, 07 c, 07 c,
  214. 07 c, 07 c, 07 c, 07 c, 07 c, 07 c, 07 c, 07 c,
  215. 05 c, 07 c, 07 c, 07 c, 07 c, 07 c, 07 c, 07 c,
  216. 07 c, 07 c, 07 c, 07 c, 07 c, 07 c, 07 c, 09 c,
  217. 09 c, 09 c, 09 c, 09 c, 09 c, 0B c, 0B c, 0B c,
  218. 0B c, 0B c, 0D c, 0D c, 0D c, 0F c, 0F c, 0F c,
  219. 0F c, 11 c, 11 c, 11 c, 13 c, 13 c, 13 c, 15 c,
  220. 15 c, 15 c, 17 c, 17 c, 19 c, 19 c, 19 c, 1B c,
  221.  
  222. 1B c, 1C c, 1C c, 1E c, 1E c, 20 c, 20 c, 22 c,
  223. 22 c, 24 c, 24 c, 26 c, 26 c, 28 c, 28 c, 2A c,
  224. 2A c, 2C c, 2C c, 2E c, 30 c, 30 c, 32 c, 32 c,
  225. 34 c, 35 c, 35 c, 37 c, 37 c, 39 c, 3B c, 3B c,
  226. 3D c, 3F c, 3F c, 41 c, 43 c, 43 c, 45 c, 47 c,
  227. 47 c, 49 c, 4B c, 4B c, 4D c, 4E c, 50 c, 50 c,
  228. 52 c, 54 c, 54 c, 56 c, 58 c, 5A c, 5A c, 5C c,
  229. 5E c, 60 c, 60 c, 62 c, 64 c, 66 c, 66 c, 67 c,
  230. 69 c, 6B c, 6D c, 6D c, 6F c, 71 c, 73 c, 73 c,
  231. 75 c, 77 c, 79 c, 7B c, 7B c, 7D c, 7F c, 80 c,
  232. here over - 2constant SINDATA
  233. decimal
  234.  
  235. hex
  236. here ( 1 cycle - shaped square 1)
  237. 80 c, 81 c, 81 c, 83 c, 85 c, 85 c, 87 c, 87 c,
  238. 89 c, 8B c, 8B c, 8D c, 8D c, 8F c, 8F c, 91 c,
  239. 91 c, 93 c, 93 c, 95 c, 97 c, 97 c, 99 c, 99 c,
  240. 9B c, 9B c, 9D c, 9D c, 9F c, 9F c, 0A1 c, 0A1 c,
  241. 0A3 c, 0A3 c, 0A5 c, 0A5 c, 0A7 c, 0A7 c, 0A9 c, 0A9 c,
  242. 0A9 c, 0AB c, 0AB c, 0AD c, 0AD c, 0AF c, 0AF c, 0B1 c,
  243. 0B1 c, 0B2 c, 0B2 c, 0B4 c, 0B4 c, 0B6 c, 0B6 c, 0B6 c,
  244. 0B8 c, 0B8 c, 0BA c, 0BA c, 0BC c, 0BC c, 0BE c, 0BE c,
  245. 0BE c, 0C0 c, 0C0 c, 0C2 c, 0C2 c, 0C4 c, 0C4 c, 0C6 c,
  246. 0C6 c, 0C6 c, 0C8 c, 0C8 c, 0CA c, 0CA c, 0CC c, 0CC c,
  247. 0CC c, 0CE c, 0CE c, 0D0 c, 0D0 c, 0D0 c, 0D2 c, 0D2 c,
  248. 0D4 c, 0D4 c, 0D4 c, 0D6 c, 0D6 c, 0D6 c, 0D8 c, 0D8 c,
  249.  
  250. 0D8 c, 0DA c, 0DA c, 0DA c, 0DC c, 0DC c, 0DC c, 0DE c,
  251. 0DE c, 0DE c, 0E0 c, 0E0 c, 0E0 c, 0E2 c, 0E2 c, 0E2 c,
  252. 0E4 c, 0E4 c, 0E4 c, 0E4 c, 0E5 c, 0E5 c, 0E5 c, 0E7 c,
  253. 0E7 c, 0E7 c, 0E7 c, 0E9 c, 0E9 c, 0E9 c, 0E9 c, 0EB c,
  254. 0EB c, 0EB c, 0ED c, 0ED c, 0ED c, 0ED c, 0EF c, 0EF c,
  255. 0EF c, 0EF c, 0EF c, 0F1 c, 0F1 c, 0F1 c, 0F1 c, 0F3 c,
  256. 0F3 c, 0F3 c, 0F3 c, 0F3 c, 0F5 c, 0F5 c, 0F5 c, 0F5 c,
  257. 0F5 c, 0F7 c, 0F7 c, 0F7 c, 0F7 c, 0F7 c, 0F9 c, 0F9 c,
  258. 0F9 c, 0F9 c, 0F9 c, 0FB c, 0FB c, 0FB c, 0FB c, 0FB c,
  259. 0FB c, 0FB c, 0FB c, 0FB c, 0FB c, 0F9 c, 0F9 c, 0F7 c,
  260. 0F5 c, 0F5 c, 0F3 c, 0F1 c, 0EF c, 0ED c, 0E9 c, 0E7 c,
  261. 0E5 c, 0E4 c, 0E2 c, 0E0 c, 0DE c, 0DC c, 0DA c, 0D8 c,
  262. 0D8 c, 0D6 c, 0D4 c, 0D2 c, 0D0 c, 0CE c, 0CC c, 0CC c,
  263. 0CA c, 0C8 c, 0C6 c, 0C4 c, 0C4 c, 0C2 c, 0C0 c, 0BE c,
  264.  
  265. 0BC c, 0BC c, 0BA c, 0B8 c, 0B6 c, 0B4 c, 0B4 c, 0B2 c,
  266. 0B1 c, 0AF c, 0AF c, 0AD c, 0AB c, 0AB c, 0A9 c, 0A7 c,
  267. 0A5 c, 0A5 c, 0A3 c, 0A1 c, 0A1 c, 9F c, 9D c, 9D c,
  268. 9B c, 99 c, 99 c, 97 c, 95 c, 95 c, 93 c, 91 c,
  269. 91 c, 8F c, 8F c, 8D c, 8B c, 8B c, 89 c, 87 c,
  270. 87 c, 85 c, 83 c, 83 c, 81 c, 81 c, 80 c, 7F c,
  271. 7F c, 7D c, 7D c, 7B c, 79 c, 79 c, 77 c, 77 c,
  272. 75 c, 73 c, 73 c, 71 c, 71 c, 6F c, 6F c, 6D c,
  273. 6D c, 6B c, 69 c, 69 c, 67 c, 67 c, 65 c, 65 c,
  274. 63 c, 63 c, 61 c, 61 c, 5F c, 5F c, 5D c, 5D c,
  275. 5B c, 5B c, 59 c, 59 c, 57 c, 57 c, 55 c, 55 c,
  276. 53 c, 53 c, 53 c, 51 c, 51 c, 4F c, 4F c, 4E c,
  277. 4E c, 4C c, 4C c, 4A c, 4A c, 48 c, 48 c, 48 c,
  278. 46 c, 46 c, 44 c, 44 c, 42 c, 42 c, 40 c, 40 c,
  279.  
  280. 3E c, 3E c, 3E c, 3C c, 3C c, 3A c, 3A c, 38 c,
  281. 38 c, 38 c, 36 c, 36 c, 34 c, 34 c, 32 c, 32 c,
  282. 32 c, 30 c, 30 c, 2E c, 2E c, 2E c, 2C c, 2C c,
  283. 2A c, 2A c, 2A c, 28 c, 28 c, 28 c, 26 c, 26 c,
  284. 26 c, 24 c, 24 c, 24 c, 22 c, 22 c, 22 c, 20 c,
  285. 20 c, 20 c, 1E c, 1E c, 1E c, 1C c, 1C c, 1C c,
  286. 1B c, 1B c, 1B c, 19 c, 19 c, 19 c, 19 c, 17 c,
  287. 17 c, 17 c, 17 c, 15 c, 15 c, 15 c, 13 c, 13 c,
  288. 13 c, 13 c, 11 c, 11 c, 11 c, 11 c, 0F c, 0F c,
  289. 0F c, 0F c, 0F c, 0D c, 0D c, 0D c, 0D c, 0B c,
  290. 0B c, 0B c, 0B c, 0B c, 09 c, 09 c, 09 c, 09 c,
  291. 07 c, 07 c, 07 c, 07 c, 07 c, 07 c, 05 c, 05 c,
  292. 05 c, 05 c, 05 c, 03 c, 03 c, 03 c, 03 c, 03 c,
  293. 03 c, 03 c, 03 c, 03 c, 03 c, 05 c, 05 c, 07 c,
  294.  
  295. 09 c, 0B c, 0B c, 0D c, 0F c, 13 c, 15 c, 17 c,
  296. 19 c, 1B c, 1C c, 1E c, 20 c, 22 c, 24 c, 26 c,
  297. 28 c, 28 c, 2A c, 2C c, 2E c, 30 c, 32 c, 32 c,
  298. 34 c, 36 c, 38 c, 3A c, 3C c, 3C c, 3E c, 40 c,
  299. 42 c, 44 c, 44 c, 46 c, 48 c, 4A c, 4A c, 4C c,
  300. 4E c, 4F c, 4F c, 51 c, 53 c, 55 c, 55 c, 57 c,
  301. 59 c, 59 c, 5B c, 5D c, 5D c, 5F c, 61 c, 61 c,
  302. 63 c, 65 c, 65 c, 67 c, 69 c, 69 c, 6B c, 6D c,
  303. 6D c, 6F c, 71 c, 71 c, 73 c, 73 c, 75 c, 77 c,
  304. 77 c, 79 c, 7B c, 7B c, 7D c, 7F c, 7F c, 80 c,
  305. here over - 2constant SQR1DATA
  306. decimal
  307.  
  308. hex
  309. here ( 1 cycle - shaped square 2)
  310. 81 c, 81 c, 83 c, 83 c, 83 c, 83 c, 85 c, 85 c,
  311. 85 c, 87 c, 87 c, 87 c, 89 c, 89 c, 89 c, 89 c,
  312. 8B c, 8B c, 8B c, 8D c, 8D c, 8D c, 8D c, 8F c,
  313. 8F c, 8F c, 91 c, 91 c, 91 c, 93 c, 93 c, 95 c,
  314. 95 c, 95 c, 97 c, 97 c, 99 c, 99 c, 9A c, 9C c,
  315. 9C c, 9E c, 9E c, 0A0 c, 0A2 c, 0A2 c, 0A4 c, 0A6 c,
  316. 0A8 c, 0AA c, 0AA c, 0AC c, 0AE c, 0B0 c, 0B2 c, 0B3 c,
  317. 0B5 c, 0B7 c, 0B9 c, 0BB c, 0BD c, 0BF c, 0C1 c, 0C3 c,
  318. 0C5 c, 0C7 c, 0C9 c, 0CB c, 0CE c, 0D0 c, 0D2 c, 0D4 c,
  319. 0D6 c, 0D8 c, 0DA c, 0DC c, 0DE c, 0E0 c, 0E2 c, 0E4 c,
  320. 0E5 c, 0E7 c, 0E9 c, 0E9 c, 0EB c, 0ED c, 0EF c, 0F1 c,
  321. 0F1 c, 0F3 c, 0F5 c, 0F5 c, 0F7 c, 0F7 c, 0F9 c, 0F9 c,
  322.  
  323. 0FB c, 0FB c, 0FB c, 0FD c, 0FD c, 0FD c, 0FE c, 0FE c,
  324. 0FE c, 0FE c, 0FE c, 0FE c, 0FE c, 0FE c, 0FE c, 0FE c,
  325. 0FE c, 0FE c, 0FE c, 0FD c, 0FD c, 0FD c, 0FD c, 0FD c,
  326. 0FB c, 0FB c, 0FB c, 0F9 c, 0F9 c, 0F9 c, 0F7 c, 0F7 c,
  327. 0F5 c, 0F5 c, 0F5 c, 0F3 c, 0F3 c, 0F1 c, 0F1 c, 0F1 c,
  328. 0EF c, 0EF c, 0ED c, 0ED c, 0ED c, 0EB c, 0EB c, 0E9 c,
  329. 0E9 c, 0E9 c, 0E7 c, 0E7 c, 0E7 c, 0E5 c, 0E5 c, 0E5 c,
  330. 0E4 c, 0E4 c, 0E4 c, 0E4 c, 0E2 c, 0E2 c, 0E2 c, 0E2 c,
  331. 0E0 c, 0E0 c, 0E0 c, 0E0 c, 0E0 c, 0DE c, 0DE c, 0DE c,
  332. 0DE c, 0DE c, 0DE c, 0DC c, 0DC c, 0DC c, 0DC c, 0DC c,
  333. 0DC c, 0DA c, 0DA c, 0DA c, 0DA c, 0DA c, 0DA c, 0D8 c,
  334. 0D8 c, 0D8 c, 0D8 c, 0D8 c, 0D6 c, 0D6 c, 0D6 c, 0D6 c,
  335. 0D4 c, 0D4 c, 0D4 c, 0D4 c, 0D4 c, 0D2 c, 0D2 c, 0D2 c,
  336. 0D2 c, 0D0 c, 0D0 c, 0D0 c, 0CE c, 0CE c, 0CE c, 0CC c,
  337.  
  338. 0CC c, 0CC c, 0CB c, 0CB c, 0CB c, 0C9 c, 0C9 c, 0C9 c,
  339. 0C7 c, 0C7 c, 0C5 c, 0C5 c, 0C3 c, 0C3 c, 0C1 c, 0C1 c,
  340. 0BF c, 0BD c, 0BD c, 0BB c, 0BB c, 0B9 c, 0B7 c, 0B5 c,
  341. 0B5 c, 0B3 c, 0B2 c, 0B0 c, 0AE c, 0AC c, 0AA c, 0A8 c,
  342. 0A6 c, 0A4 c, 0A2 c, 0A0 c, 9E c, 9C c, 9A c, 99 c,
  343. 97 c, 93 c, 91 c, 8F c, 8D c, 89 c, 87 c, 85 c,
  344. 81 c, 80 c, 7F c, 7B c, 79 c, 77 c, 73 c, 71 c,
  345. 6F c, 6B c, 69 c, 67 c, 64 c, 62 c, 60 c, 5E c,
  346. 5A c, 58 c, 56 c, 54 c, 52 c, 50 c, 4E c, 4D c,
  347. 4B c, 49 c, 47 c, 45 c, 43 c, 41 c, 3F c, 3F c,
  348. 3D c, 3B c, 39 c, 39 c, 37 c, 37 c, 35 c, 34 c,
  349. 34 c, 32 c, 32 c, 30 c, 30 c, 2E c, 2E c, 2E c,
  350. 2C c, 2C c, 2C c, 2A c, 2A c, 28 c, 28 c, 28 c,
  351. 26 c, 26 c, 26 c, 24 c, 24 c, 24 c, 22 c, 22 c,
  352.  
  353. 22 c, 20 c, 20 c, 20 c, 1E c, 1E c, 1E c, 1C c,
  354. 1C c, 1B c, 1B c, 19 c, 19 c, 19 c, 17 c, 17 c,
  355. 15 c, 15 c, 13 c, 13 c, 13 c, 11 c, 11 c, 0F c,
  356. 0F c, 0D c, 0D c, 0D c, 0B c, 0B c, 0B c, 09 c,
  357. 09 c, 09 c, 07 c, 07 c, 07 c, 05 c, 05 c, 05 c,
  358. 05 c, 05 c, 05 c, 03 c, 03 c, 03 c, 03 c, 03 c,
  359. 03 c, 03 c, 03 c, 03 c, 03 c, 05 c, 05 c, 05 c,
  360. 05 c, 05 c, 05 c, 05 c, 07 c, 07 c, 07 c, 07 c,
  361. 09 c, 09 c, 09 c, 09 c, 0B c, 0B c, 0B c, 0D c,
  362. 0D c, 0D c, 0F c, 0F c, 0F c, 0F c, 11 c, 11 c,
  363. 11 c, 13 c, 13 c, 13 c, 15 c, 15 c, 15 c, 15 c,
  364. 17 c, 17 c, 17 c, 17 c, 19 c, 19 c, 19 c, 1B c,
  365. 1B c, 1B c, 1B c, 1C c, 1C c, 1C c, 1E c, 1E c,
  366. 1E c, 20 c, 20 c, 20 c, 22 c, 22 c, 22 c, 24 c,
  367.  
  368. 24 c, 26 c, 26 c, 26 c, 28 c, 28 c, 2A c, 2A c,
  369. 2C c, 2C c, 2E c, 30 c, 30 c, 32 c, 32 c, 34 c,
  370. 35 c, 35 c, 37 c, 37 c, 39 c, 3B c, 3B c, 3D c,
  371. 3F c, 3F c, 41 c, 43 c, 45 c, 45 c, 47 c, 49 c,
  372. 49 c, 4B c, 4D c, 4D c, 4E c, 50 c, 52 c, 52 c,
  373. 54 c, 56 c, 56 c, 58 c, 5A c, 5A c, 5C c, 5E c,
  374. 5E c, 60 c, 62 c, 62 c, 64 c, 64 c, 66 c, 67 c,
  375. 67 c, 69 c, 69 c, 6B c, 6D c, 6D c, 6F c, 6F c,
  376. 71 c, 71 c, 73 c, 73 c, 75 c, 75 c, 77 c, 77 c,
  377. 79 c, 79 c, 79 c, 7B c, 7B c, 7D c, 7D c, 7F c,
  378. here over - 2constant SQR2DATA
  379. decimal
  380.  
  381. hex
  382. here ( exponential data - approx 10 mS at 11025 b/s)
  383. 0F4 c, 0E9 c, 0DE c, 0D5 c, 0CB c, 0C2 c, 0BA c, 0B1 c,
  384. 0A9 c, 0A2 c, 9B c, 94 c, 8D c, 87 c, 81 c, 7B c,
  385. 76 c, 71 c, 6C c, 67 c, 62 c, 5E c, 5A c, 56 c,
  386. 52 c, 4E c, 4B c, 47 c, 44 c, 41 c, 3E c, 3C c,
  387. 39 c, 36 c, 34 c, 32 c, 2F c, 2D c, 2B c, 29 c,
  388. 28 c, 26 c, 24 c, 23 c, 21 c, 20 c, 1E c, 1D c,
  389. 1B c, 1A c, 19 c, 18 c, 17 c, 16 c, 15 c, 14 c,
  390. 13 c, 12 c, 11 c, 11 c, 10 c, 0F c, 0F c, 0E c,
  391. 0D c, 0D c, 0C c, 0C c, 0B c, 0B c, 0A c, 0A c,
  392. 09 c, 09 c, 08 c, 08 c, 08 c, 07 c, 07 c, 07 c,
  393. 06 c, 06 c, 06 c, 06 c, 05 c, 05 c, 05 c, 05 c,
  394. 04 c, 04 c, 04 c, 04 c, 04 c, 04 c, 03 c, 03 c,
  395.  
  396. 03 c, 03 c, 03 c, 03 c, 03 c, 02 c, 02 c, 02 c,
  397. 02 c, 02 c, 02 c, 02 c, 02 c, 02 c,
  398. here over - 2constant EXPDATA
  399. decimal
  400.  
  401. : EXPSIZ ( -- n ) expdata nip ;
  402.  
  403. defer CYCLEDATA
  404.  
  405. : SINWAVE ( -- ) ['] sindata is cycledata ;
  406. : SQR1WAVE ( -- ) ['] sqr1data is cycledata ;
  407. : SQR2WAVE ( -- ) ['] sqr2data is cycledata ;
  408.  
  409. sqr1wave
  410.  
  411. \ Koch characters
  412. create KTABLE ( -- a )
  413. char K c, char M c, char R c, char S c, char U c,
  414. char A c, char P c, char T c, char L c, char O c,
  415. char W c, char I c, char . c, char N c, char J c,
  416. char E c, char F c, char 0 c, char Y c, char V c,
  417. char , c, char G c, char 5 c, char / c, char Q c,
  418. char 9 c, char Z c, char H c, char 3 c, char 8 c,
  419. char B c, char ? c, char 4 c, char 2 c, char 7 c,
  420. char C c, char 1 c, char D c, char 6 c, char X c,
  421. here ktable - to #koch
  422.  
  423. \ Table of valid characters
  424. create LOOKUP ( -- a )
  425. bl c, here ( *)
  426. char A c, char B c, char C c, char D c, char E c,
  427. char F c, char G c, char H c, char I c, char J c,
  428. char K c, char L c, char M c, char N c, char O c,
  429. char P c, char Q c, char R c, char S c, char T c,
  430. char U c, char V c, char W c, char X c, char Y c,
  431. char Z c,
  432. char 0 c, char 1 c, char 2 c, char 3 c, char 4 c,
  433. char 5 c, char 6 c, char 7 c, char 8 c, char 9 c,
  434. ( *) here over - to #basic
  435. char . c, char / c, char ? c,
  436. ( *) here over - to #punct
  437.  
  438. char ! c, char " c, char $ c, char & c, char ' c,
  439. char + c, char , c, char - c, char : c, char ; c,
  440. char = c, char _ c, char ( c, char ) c,
  441. ( *) here over - to #extended
  442. \ ARRL Morse Practice control codes
  443. $83 c, $89 c, $82 c,
  444. ( *) here swap - to #controls
  445.  
  446. \ Get default wave filetype
  447. : WAVETYPE ( -- a u )
  448. outdev
  449. 1 of s" WAV" end
  450. 2 of s" VOC" end
  451. drop here 0 ;
  452.  
  453. : SETVOICE ( a u -- a' 0 )
  454. firstnum if
  455. 0 of sinwave end
  456. 1 of sqr1wave end
  457. 2 of sqr2wave end
  458. badoption
  459. then ;
  460.  
  461. : SETFORM ( a u -- a' 0 )
  462. firstnum if groupcols !
  463. nextnum if grouprows !
  464. nextnum if groupsize ! then
  465. then
  466. then ;
  467.  
  468. : SETSPACE ( a u -- a' 0 ) \ values checked later
  469. firstnum if wspace !
  470. nextnum if cspace ! then
  471. then ;
  472.  
  473. : SETSPEED ( a u -- a' 0 ) \ values checked later
  474. firstnum if send.s !
  475. nextnum if 0 of send.s @ then char.s ! then
  476. then ;
  477.  
  478. : SETKOCH ( a u -- a' 0 )
  479. firstnum if \ use Koch character set
  480. dup 2 #koch between ?badoption
  481. koch ! 2 punct !
  482. then ;
  483.  
  484. :noname ( a u char -- a u )
  485. upcase
  486. [char] S of setspeed end
  487. [char] C of /num char.s ! end
  488. [char] D of setspace end
  489. [char] T of 400 1000 /numrange tone ! end
  490. [char] P of 0 2 /numrange punct ! end
  491. [char] O of compress off end
  492. [char] W of 1 to outdev setvoice end
  493. [char] V of 2 to outdev setvoice end
  494. [char] U of 0 9 /numrange volume ! end
  495. [char] G of train off compress off setkoch end
  496.  
  497. [char] R of train off compress off
  498. #koch min dup koch ! 2dup upper
  499. ktable swap cmove 2 punct ! 0 0 end
  500. [char] F of setform end
  501. [char] I of ignore on end
  502. [char] L of lsignal on end
  503. [char] H of true to hide end
  504. badoption ; is setoption
  505.  
  506. \ Parse filenames
  507. :noname ( -- )
  508. argv 0= if help then
  509. s" TXT" +ext infile !fname
  510. argv 0= if \ no second name
  511. infile @fname \ use first
  512. train @ if -path -ext then
  513. then
  514. outdev if wavetype else s" TXT" then +ext
  515. outfile !fname ; is parsefilename
  516.  
  517. \ Wait for a key and randomize seed
  518. : ANYKEY ( -- )
  519. cr ." [Any key to begin - ESC quits]"
  520. begin
  521. 1 rnd +! key?
  522. until ?stopkey cr ;
  523.  
  524. : SPEEDCHECK ( -- )
  525. send.s @ char.s @
  526. 2dup speedrange between swap speedrange between and 0= if
  527. cr ." Speed out of range" .abort
  528. then > if
  529. cr ." Send speed greater than char speed" .abort
  530. then ;
  531.  
  532. : SPACECHECK ( -- )
  533. cspace @ dup 2 < if
  534. cr ." Char space less than 2" .abort
  535. then
  536. wspace @ > if
  537. cr ." Word space less than char space" .abort
  538. then ;
  539.  
  540. \ Show settings
  541. : .SETTINGS ( -- ) hide not if cr
  542. send.s @ 0 .r [char] / emit char.s @ . ." WPM "
  543. wspace @ 0 .r [char] / emit cspace @ . ." SPC "
  544. tone @ . ." Hz " koch @ ?dup if
  545. . ." chars "
  546. else punct @ cond
  547. 1 of ." basic" else
  548. 2 of ." full" else
  549. drop ." no"
  550. cont ." punct "
  551. then
  552. compress @ 0= if ." no compress " then
  553. lsignal @ if ." line signals" then cr
  554. then speedcheck spacecheck ;
  555.  
  556. hex
  557. here ( WAV header)
  558. 52 c, 49 c, 46 c, 46 c, 00 c, 00 c, 00 c, 00 c,
  559. 57 c, 41 c, 56 c, 45 c, 66 c, 6D c, 74 c, 20 c,
  560. 10 c, 00 c, 00 c, 00 c, 01 c, 00 c, 01 c, 00 c,
  561. 11 c, 2B c, 00 c, 00 c, 11 c, 2B c, 00 c, 00 c,
  562. 01 c, 00 c, 08 c, 00 c, 64 c, 61 c, 74 c, 61 c,
  563. 00 c, 00 c, 00 c, 00 c,
  564. here over - 2constant WAV-HDR
  565. decimal
  566.  
  567. hex
  568. here ( VOC header)
  569. 43 c, 72 c, 65 c, 61 c, 74 c, 69 c, 76 c, 65 c,
  570. 20 c, 56 c, 6F c, 69 c, 63 c, 65 c, 20 c, 46 c,
  571. 69 c, 6C c, 65 c, 1A c, 1A c, 00 c, 0A c, 01 c,
  572. 29 c, 11 c, 01 c, 00 c, 00 c, 00 c, A5 c, 00 c,
  573. here over - 2constant VOC-HDR
  574. decimal
  575.  
  576. 0 value CYCADR ( -- adr ) \ cycle data
  577. 0 value SPCADR ( -- adr ) \ space data
  578. 0 value POINTS ( -- n ) \ points per cycle
  579. 0 value RISEADR ( -- adr ) \ rising data
  580. 0 value DECAYADR ( -- adr ) \ decaying data
  581. 0 value EPOINTS ( -- n ) \ points per exp cycles
  582.  
  583. : CYCLEWAVE ( -- a n ) cycadr points ;
  584. : SPACEWAVE ( -- a n ) spcadr points ;
  585. : RISEWAVE ( -- a n ) riseadr epoints ;
  586. : DECAYWAVE ( -- a n ) decayadr epoints ;
  587. : MS-LOOPS ( -- u1 u2 ) ratio 2@ ;
  588.  
  589. create LOGVAL \ logarithmic volume levels
  590. \ -24 -21 -18 -15 -12 -9 -6 -3 0
  591. 0 c, 16 c, 23 c, 32 c, 45 c, 64 c, 90 c, 128 c, 180 c, 255 c,
  592.  
  593. \ Apply volume to sample
  594. : +VOL ( x -- x' )
  595. $80 - volume @ logval + c@ 255 */ $80 + ;
  596.  
  597. \ Generate cycle data for specified tone
  598. : GENWAVE ( -- )
  599. points reserve to cycadr
  600. cycledata ( a n) points / tuck
  601. ( step a step) 2/ - ( center sampled data) ( step a')
  602. points 0 ?do
  603. over + dup c@ +vol cycadr i + c!
  604. loop 2drop ;
  605.  
  606. \ Reserve epoints of cycledata for shaping
  607. : ERESERVE ( -- adr )
  608. epoints dup 1+ reserve dup rot points / 0 ?do
  609. >r cyclewave r@ swap cmove r> points +
  610. loop drop ;
  611.  
  612. \ Generate rising data (approx 10 mS)
  613. : GENRISE ( -- )
  614. ereserve dup to riseadr
  615. ( adr) expdata bounds do
  616. dup c@ $80 - 255 i c@ - 255 */ $80 + over c! 1+
  617. loop drop ;
  618.  
  619. \ Generate decaying data (approx 10 mS)
  620. : GENDECAY ( -- )
  621. ereserve dup to decayadr epoints + expsiz -
  622. ( adr) expdata bounds do
  623. dup c@ $80 - i c@ 255 */ $80 + over c! 1+
  624. loop drop ;
  625.  
  626. : GENSPC ( -- ) \ gen space data for specified tone
  627. points reserve to spcadr
  628. points 0 ?do $80 spcadr i + c! loop ;
  629.  
  630. : SETRATIO ( -- ) \ set loops/msec for specified tone
  631. 100 points over * 1000 um* bitrate um/mod nip ratio 2! ;
  632.  
  633. : SETPOINTS ( -- ) \ set points for specified tone
  634. bitrate tone @ / dup to points
  635. expsiz over /mod swap if 1+ then * to epoints ;
  636.  
  637. : INITWAVE ( -- )
  638. setpoints setratio genwave genrise gendecay genspc ;
  639.  
  640. \ Write header
  641. : STARTWAVE ( -- )
  642. 0. wavesiz 2!
  643. outdev
  644. 1 of wav-hdr writedata end
  645. 2 of voc-hdr writedata end
  646. drop ;
  647.  
  648. \ Patch WAV/VOC data size
  649. : !SIZE ( u -- )
  650. wavesiz 2@ swap pad 2! pad swap writedata ;
  651.  
  652. \ Patch size
  653. : ENDWAVE ( -- )
  654. outdev
  655. 1 of 0 pad c! pad 1 writedata
  656. 40. seekoutfile 4 !size
  657. 36 wavesiz m+!
  658. 4. seekoutfile 4 !size end
  659. 2 of 0 pad c! pad 1 writedata
  660. 2 wavesiz m+!
  661. 27. seekoutfile 3 !size end
  662. drop ;
  663.  
  664. \ Write u bytes wavedata to file
  665. : WRITEWAVE ( a u -- )
  666. tuck writedata wavesiz m+! ;
  667.  
  668. \ Write wavedata to file for n millisec
  669. : WRITEMSEC ( a u ms -- )
  670. ms-loops */ 0 ?do 2dup writewave loop 2drop ;
  671.  
  672. \ Adjust for rise/decay period
  673. : ADJUST ( ms1 -- ms2 )
  674. epoints 1000 bitrate */ - 0 max ;
  675.  
  676. \ Output morse beep for n millisec
  677. : MBEEP ( n -- )
  678. outdev if
  679. risewave writewave shaping on
  680. cyclewave rot adjust writemsec
  681. end tone @ swap sound ;
  682.  
  683. \ Output morse quiet for n millisec
  684. : MQUIET ( n -- )
  685. outdev if
  686. shaping @ if ( complete previous MBEEP )
  687. adjust decaywave writewave shaping off
  688. then spacewave rot writemsec
  689. end ms ;
  690.  
  691. \ To keep average word speed correct adjust for plain or random
  692. \ text (not implemented)
  693.  
  694. \ Set plain text mode
  695. : PLAIN-TEXT ( -- )
  696. 31 to d_elements 19 to s_elements rndtxt off ;
  697.  
  698. \ Set random text mode
  699. : RANDOM-TEXT ( -- )
  700. 41 to d_elements 19 to s_elements rndtxt on ;
  701.  
  702. \ TIM is basic timing element (one DIT). SPC is basic spacing
  703. \ element. If character/send speed are same then SPC=TIM.
  704.  
  705. \ Length of one DIT (msec)
  706. : TIM ( -- ms )
  707. 60 1000 char.s @ d_elements s_elements + * */ ;
  708.  
  709. \ Length of one space (msec)
  710. : SPC ( -- ms )
  711. 60 1000 send.s @ */ tim d_elements * - s_elements / ;
  712.  
  713. \ Each morse element followed by 1*TIM space
  714. : DI ( -- ) tim mbeep tim mquiet ;
  715. : DA ( -- ) tim 3 * mbeep tim mquiet ;
  716.  
  717. \ Each morse character followed by 3*SPC partial word space
  718. : DIT ( -- ) tim mbeep spc cspace @ * mquiet spacing on ;
  719. : DAH ( -- ) tim 3 * mbeep spc cspace @ * mquiet spacing on ;
  720.  
  721. \ Word space adjusted for preceding partial
  722. : __ ( -- ) spc wspace @ cspace @ spacing @ and - * mquiet
  723. spacing off ;
  724.  
  725. \ Insert word space only if preceding partial
  726. : ?SPACE ( -- ) spacing @ if __ then ;
  727.  
  728. vocabulary MORSE
  729. morse definitions warning off
  730.  
  731. \ Letters
  732. : A DI DAH ; : B DA DI DI DIT ; : C DA DI DA DIT ;
  733. : D DA DI DIT ; : E DIT ; : F DI DI DA DIT ;
  734. : G DA DA DIT ; : H DI DI DI DIT ; : I DI DIT ;
  735. : J DI DA DA DAH ; : K DA DI DAH ; : L DI DA DI DIT ;
  736. : M DA DAH ; : N DA DIT ; : O DA DA DAH ;
  737. : P DI DA DA DIT ; : Q DA DA DI DAH ; : R DI DA DIT ;
  738. : S DI DI DIT ; : T DAH ; : U DI DI DAH ;
  739. : V DI DI DI DAH ; : W DI DA DAH ; : X DA DI DI DAH ;
  740. : Y DA DI DA DAH ; : Z DA DA DI DIT ;
  741.  
  742. \ Numbers
  743. : 1 DI DA DA DA DAH ; : 2 DI DI DA DA DAH ;
  744. : 3 DI DI DI DA DAH ; : 4 DI DI DI DI DAH ;
  745. : 5 DI DI DI DI DIT ; : 6 DA DI DI DI DIT ;
  746. : 7 DA DA DI DI DIT ; : 8 DA DA DA DI DIT ;
  747. : 9 DA DA DA DA DIT ; : 0 DA DA DA DA DAH ;
  748.  
  749. \ Basic punctuation
  750. : . DI DA DI DA DI DAH ; : ? DI DI DA DA DI DIT ;
  751. : / DA DI DI DA DIT ;
  752.  
  753. \ Extended punctuation
  754. : ! DA DI DA DI DA DAH ; : " DI DA DI DI DA DIT ;
  755. : $ DI DI DI DA DI DI DAH ; : & DI DA DI DI DIT ;
  756. : ' DI DA DA DA DA DIT ; : + DI DA DI DA DIT ;
  757. : , DA DA DI DI DA DAH ; : - DA DI DI DI DI DAH ;
  758. : :: DA DA DA DI DI DIT ; : ;; DA DI DA DI DA DIT ;
  759. : = DA DI DI DI DAH ; : _ DI DI DA DA DI DAH ;
  760. : (( DA DI DA DA DIT ; : ) DA DI DA DA DI DAH ;
  761.  
  762. \ Prosigns
  763. : AA DI DA DI DAH ; : AR DI DA DI DA DIT ;
  764. : AS DI DA DI DI DIT ; : BT DA DI DI DI DAH ;
  765. : CT DA DI DA DI DAH ;
  766. : HH DI DI DI DI DI DI DI DIT ; : KN DA DI DA DA DIT ;
  767. : SK DI DI DI DA DI DAH ; : SN DI DI DI DA DIT ;
  768. : SOS DI DI DI DA DA DA DI DI DIT ;
  769.  
  770. aka SK VA aka SN VE aka CT KA
  771.  
  772. forth definitions
  773. warning on
  774.  
  775. \ Send 1 minute of morse
  776. \ Using DOS under Windows will result in longer times
  777. : CALIBRATE ( -- )
  778. send.s @ 0 do
  779. rndtxt @ if
  780. [ morse ] C O D E X __ [ forth ]
  781. else
  782. [ morse ] P A R I S __ [ forth ]
  783. then
  784. key? if key drop break
  785. loop beep ;
  786.  
  787. \ Morse execution table - must match LOOKUP
  788. create MTABLE ( -- a )
  789. morse ]
  790. __
  791. A B C D E F G H I J K L M
  792. N O P Q R S T U V W X Y Z
  793. 0 1 2 3 4 5 6 7 8 9
  794. . / ?
  795. ! " $ & ' + , - :: ;; = _ (( )
  796. AS BT AR
  797. [ forth
  798.  
  799. \ Return range of valid characters
  800. : VALIDRANGE ( -- n )
  801. punct @
  802. 0 of #basic end
  803. 1 of #punct end
  804. 2 of #controls end \ include ARRL controls
  805. drop #basic ;
  806.  
  807. \ Select character set for random groups
  808. : CHARSET ( -- adr len )
  809. koch @ ?dup if ktable else
  810. validrange #extended min \ exclude ARRL controls
  811. lookup 1+
  812. then swap ;
  813.  
  814. \ Create group buffer
  815. : ALLOTGBUF ( -- )
  816. groupcols @ grouprows @ * groupsize @ *
  817. ( size) dup gmax 1+ 1 within if
  818. cr ." Groups must be 1.." gmax . ." chars" .abort
  819. then dup to gsize reserve to gbuf ;
  820.  
  821. \ Fill group buffer with charset until full
  822. : FILLGBUF ( adr len -- )
  823. gsize over /mod 2>r
  824. gbuf r> 0 ?do ( chunks)
  825. >r 2dup r@ swap cmove dup r> +
  826. loop swap r> ( remaining) min cmove ;
  827.  
  828. \ Fill group buffer with shuffled characters
  829. : FILLRANDOM ( -- )
  830. allotgbuf charset fillgbuf gbuf gsize shuffle ;
  831.  
  832. \ Get randomized ascii char from buffer
  833. \ If char same as last rotate it to bottom
  834. : RANDOMCHAR ( -- char )
  835. gbuf c@ gsize 0 do
  836. dup lastchar @ - if break
  837. gbuf dup gsize 1 /string rot swap cmove
  838. ( c) gbuf gsize + 1- c! gbuf c@
  839. loop dup lastchar !
  840. gbuf 1+ to gbuf gsize 1- to gsize ;
  841.  
  842. \ Write string to file
  843. : WRITECHARS ( a u -- ) bounds ?do i c@ writechar loop ;
  844.  
  845. \ Write end-of-line to file
  846. : WRITECR ( -- ) (cr) writechars ;
  847.  
  848. \ Write one line of groups
  849. : RANDOMLINE ( -- )
  850. groupcols @ 0 ?do
  851. bl writechar space
  852. groupsize @ 0 ?do randomchar dup ?emit writechar loop
  853. loop writecr ?cr ;
  854.  
  855. \ Save settings to file
  856. : !SETTINGS ( -- )
  857. s" [options]" writechars
  858. s" -s" writechars send.s @ (.) writechars
  859. s" -c" writechars char.s @ (.) writechars
  860. s" -d" writechars wspace @ (.) writechars
  861. cspace @ dup 3 <> and ?dup if
  862. [char] , writechar (.) writechars
  863. then
  864. s" -t" writechars tone @ (.) writechars
  865. s" -o" compress @ 0= and writechars
  866. s" -p" writechars punct @ (.) writechars
  867. s" -l" lsignal @ 0<> and writechars
  868. s" -u" writechars volume @ (.) writechars
  869. writecr ;
  870.  
  871. \ Make random groups
  872. : MAKEGROUPS ( -- )
  873. .settings !settings anykey
  874. fillrandom lastchar off
  875. grouprows @ 0 ?do randomline loop ;
  876.  
  877. \ Character substitution
  878. : SUBSTITUTE ( char1 -- char2 )
  879. [char] [ of [char] ( end
  880. [char] ] of [char] ) end
  881. [char] { of [char] ( end
  882. [char] } of [char] ) end
  883. ;
  884.  
  885. \ Check character substitute space if invalid
  886. : CHECKCHAR ( char1 -- char2 index )
  887. validrange
  888. begin
  889. 2dup lookup + c@ <>
  890. over 0<> and
  891. while
  892. 1-
  893. repeat
  894. dup 0= if ( invalid or space )
  895. nip bl swap
  896. then ;
  897.  
  898. \ Sound the character
  899. : SOUNDCHAR ( index -- ) cells mtable + @ execute ;
  900.  
  901. \ Output char to screen and speaker
  902. : MORSECHAR ( char -- )
  903. substitute checkchar
  904. over bl = lastchar @ bl = and if
  905. drop ( repeated space and compress on)
  906. else
  907. over ?emit soundchar
  908. then
  909. ( char) compress @ and lastchar ! ;
  910.  
  911. \ Send start of line sequence
  912. : STARTLINE ( -- )
  913. lsignal @ whitespace @ not and if
  914. 1000 mquiet [ morse ] CT [ forth ] 1000 mquiet
  915. then ;
  916.  
  917. \ Send end of line sequence
  918. : ENDLINE ( -- )
  919. ?space \ complete any partial space
  920. lsignal @ whitespace @ not and if
  921. 1000 mquiet [ morse ] AR [ forth ] 1000 mquiet
  922. then ;
  923.  
  924. variable PCHAR \ proc type - prosign or PCM sample
  925.  
  926. create PBUF linemax allot \ hash code or PCM filename
  927.  
  928. : PNAME ( -- a u ) pbuf count ;
  929.  
  930. : /PROC ( -- ) pchar off pbuf off lastchar off ;
  931.  
  932. : +HASH ( c -- ) pbuf @ 4 lshift xor pbuf ! ;
  933. : +PNAME ( c -- ) pname dup 1+ pbuf c! + c! ;
  934.  
  935. : +PROC ( c -- ) pchar @
  936. [char] \ of +hash end
  937. [char] | of +pname end
  938. drop ;
  939.  
  940. system
  941. : HASH ( "ccc" -- ) /proc token bounds
  942. ?do i c@ +hash loop pbuf @ postpone literal ; immediate
  943. application
  944.  
  945. \ Output prosign to speaker if ready
  946. : DO-PROSIGN ( -- ) ?space pbuf @
  947. hash AA of [ morse ] AA [ forth ] end
  948. hash AR of [ morse ] AR [ forth ] end
  949. hash AS of [ morse ] AS [ forth ] end
  950. hash BT of [ morse ] BT [ forth ] end
  951. hash CT of [ morse ] CT [ forth ] end
  952. hash HH of [ morse ] HH [ forth ] end
  953. hash KA of [ morse ] KA [ forth ] end
  954.  
  955. hash KN of [ morse ] KN [ forth ] end
  956. hash SK of [ morse ] SK [ forth ] end
  957. hash SN of [ morse ] SN [ forth ] end
  958. hash SOS of [ morse ] SOS [ forth ] end
  959. hash VA of [ morse ] VA [ forth ] end
  960. hash VE of [ morse ] VE [ forth ] end
  961. drop s" <- unknown prosign ... ignoring" ?type ?cr
  962. ;
  963.  
  964. handle PCMFILE \ create PCM file handle
  965. : PCMOPEN ( a u fam -- ) pcmfile tuck 2>r !fname 2r> (fopen) ;
  966. : PCMREAD ( a u -- a u' ) pcmfile >fid fread eof trim ;
  967. : PCMCLOSE ( -- ) pcmfile fclose drop ;
  968.  
  969. \ Read PCM sample from disk
  970. : GETSAMPLE ( a u -- a' u' )
  971. r/o pcmopen pad unused 32767 umin pcmread pcmclose
  972. 0 trim #pcmhdr /string 0 max ;
  973.  
  974. \ Insert PCM sample
  975. : DO-PCM ( -- )
  976. outdev if
  977. pname s" pcm" +ext getsample writewave spacing off
  978. end 900 ms ;
  979.  
  980. \ Output procedure if exists
  981. : ?SENDPROC ( -- )
  982. pchar @ ?dup if
  983. cond
  984. [char] \ of do-prosign else
  985. [char] | of do-pcm else
  986. drop cont
  987. then /proc ;
  988.  
  989. : SENDLINE ( a u -- )
  990. /proc bounds ?do
  991. i c@ dup $20 or $7c = if \ chars '\' or '|'
  992. ?sendproc dup pchar ! ( c) ?emit
  993. else
  994. pchar @ if \ within proc
  995. dup bl = if \ end proc
  996. ?sendproc ( bl) morsechar
  997. else
  998. ( c) dup +proc ?emit \ for each proc char
  999. then
  1000. else ( c) morsechar then
  1001. then
  1002. ?stop
  1003. loop ?sendproc ; \ handle proc at EOL
  1004.  
  1005. \ Convert control chars, case and test whitespace
  1006. : CLEAN ( a u -- a u' )
  1007. 2dup >blanks 2dup upper
  1008. 2dup -trailing nip 0= whitespace ! ;
  1009.  
  1010. \ Output current line as Morse
  1011. : MORSELINE ( -- )
  1012. line 2@ clean
  1013. over c@ [char] # = over 0<> and ( comment)
  1014. over 0= ( empty line) or if ?type end
  1015. startline sendline endline ;
  1016.  
  1017. \ Get settings from file
  1018. : @SETTINGS ( -- flag )
  1019. line 2@ bl split
  1020. s" [OPTIONS]" caps compare if 2drop false end
  1021. !arg ignore @ not if parseoption initwave then true ;
  1022.  
  1023. \ Get a line of text from file
  1024. : GETLINE ( -- flag)
  1025. lbuf linemax readtext -rot line 2! ;
  1026.  
  1027. \ Send text file as morse
  1028. : SENDMORSE ( -- )
  1029. outdev 0= if anykey then
  1030. getline if ( file not empty)
  1031. initwave @settings ( flag) .settings
  1032. startwave 4000 mquiet
  1033. begin
  1034. ( flag) 0= if morseline ?cr then getline
  1035. while ( not EOF)
  1036. @settings dup if .settings then
  1037. repeat
  1038. 2000 mquiet endwave
  1039. then ;
  1040.  
  1041. \ Run application
  1042. : (RUN) ( -- )
  1043. train @ if
  1044. cr ." infile: " infile .fname r/o openinfile
  1045. outdev if
  1046. cr ." outfile: " outfile .fname r/w makeoutfile
  1047. then
  1048. cr sendmorse
  1049. else
  1050. cr ." outfile: " outfile .fname r/w makeoutfile
  1051. cr makegroups
  1052. then
  1053. closefiles ;
  1054.  
  1055. \ Set application defaults
  1056. : DEFAULTS ( -- )
  1057. 0 to outdev shaping off spacing off
  1058. train on koch off
  1059. plain-text punct off compress on ignore off
  1060. 7 send.s ! 15 char.s ! 3 cspace ! 7 wspace !
  1061. 700 tone ! 7 volume ! sqr1wave
  1062. 6 groupcols ! 4 grouprows ! 3 groupsize !
  1063. lsignal off 0 to hide ;
  1064.  
  1065. defaults
  1066.  
  1067. \ Run application with error handling
  1068. : RUN ( -- )
  1069. ['] (run) catch ?dup if >r onerror r> throw then ;
  1070.  
  1071. \ Main
  1072. : PROGRAM ( -- )
  1073. onstart \ startup initialization
  1074. con-io \ default console mode
  1075. defaults \ set defaults
  1076. cr title \ show application name
  1077. cmdtail parsecmd \ process command-line
  1078. run \ run application
  1079. cr ." done" \ show success
  1080. ;
  1081.  
  1082.  
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!