$MORSE.REX
The following is the $MORSE.REX (REXX) program. <lang rexx>/**/trace o; parse arg !; if !all(arg()) then exit if !cms then address signal on halt; signal on novalue; signal on syntax
if !== then exit @abc='abcdefghijklmnopqrstuvwxyz'; @abcU=@abc; upper @abcU parse var ! ops '(' plainText ops = space(ops)
dah = '-'
dit = '.'
if !cms then dit = 'af'x if !dos then dit = 'f9'x
/* _b1, _v2, and _b3 are pseudo-blanks and they */
_b1 = 'b0'x /* should be a character that can't be entered from */ _b2 = 'b1'x /* the keyboard easily. They are translated to */ _b3 = 'b2'x /* true blanks by the tt internal subrountine. */
colors = !cms | !pcrexx | !r4 | !roo /*REXXes that support color. */ betweens = 0 /*blanks between Morse symbols. */ bf = 400 /*beat frequency (internal spkr).*/ clear = 0 /*clear the terminal screen (| ¬)*/ code = /*Morse code characters (so far).*/ delayspace = 1 emsg = 1 logs = 0 long_ = '=' longer_ = '~' long = '__' /*long dash.*/ longer = '____' /*longer dash.*/ morsetype = 'I' pause_ = '¬' quiet = 0 show = 0 slice = 0 sound = 1 spaces = 3 split = 1 spread = 1 tfid = /*the temporary file identifier. */
timedelay = .2 dittime = .1 dahtime = .2 longtime = .4
longertime = .8
pausetime = .15
tops =
sw = linesize() /*get the terminal screen width. */
do while ops\== parse var ops _1 2 1 _ . 1 _o ops upper _
select
when _==',' then nop
when _1=='.' & pos("=",_)\==0 then tops= tops _o
when abbn('CLearscreen') then clear = no()
when abbn('COLORs') then colors = no()
when abbn('LOGs') then logs = no()
when abbn('EMSGs') then emsg = no()
when abbn('SPLit') then split = no()
when abbn('Quiet') then quiet = no()
when abbn('SHOWcodes') then show = no()
when abbn('SOUnds')|,
abbn('BEEPs') then sound = no()
when abbn('SLIce') then slice = no()
when abb('BETWEENs') then do
betweens = nai()
if betweens<0 | betweens>sw then call er 81,0 sw betweens 'betweens'
end
when abb('DAHs')|,
abb('DASHs')|,
abb('DASHes') then dah = na()
when abb('DITs')|,
abb('DOTs') then dit = na()
when abb('LONGs') then long = na()
when abb('LONGERs') then longer = na()
when abb('SPAces') then do
spaces = nai()
if spaces<0 | spaces>sw then call er 81,0 sw spaces 'spaces'
end
when abb('SPREADs') then do
spread = nai()
if spread<0 | spread>sw then call er 81,0 sw spread 'spread'
end
when abb('AMERican') |,
abb('INTERnational') |,
abb('RAILroads') |,
abb('RAILways') |,
abb('RRs') |,
abb('USa') then morsetype = _1
otherwise call er 55,_o
end /*select*/
end /*while ops\==*/
w=words(plainText) if w==0 & emsg & \show then call er 35,'( plain-text' dah = verchar(dah,'DAH') /*verify dah Morse character.*/ dit = verchar(dit,'DIT') /* " dit " " */ if morsetype\=='I' then morsetype="R" /*Not internatioal? Assume R.R.*/ morsetype = '0'morsetype /*construct "type" of Morse code.*/ between_ = copies(' ',betweens) /*construct # of between blanks. */ if logs then tops = '.F='gettfid(,"ANS") tops if colors then tops = '.C=green' tops /*add color (if any) to TOPS. */ tops = space(tops) /*get rid of extraneous blanks. */ _ = dah @ = dit if clear & \quiet then !cls /*should we clear the screen? */ /*┌───────────────────────────────────────────────────────────────────┐
│ 1 2 3 4 5 │ │ 123456789012345678901234567890123456789012345678901234 │ │ ABCDEFGHIJKLMNOPQRSTUVWZYZ0123456789':,-(.?;/_$!)=@&"+ │ └───────────────────────────────────────────────────────────────────┘*/
@chars = @abcu || "0123456789':,-(.?;/_$!)=@&""+" $.= $.0i.1 = mc(@ _) /* A letter */ $.0i.2 = mc(_ @ @ @) /* B letter */ $.0i.3 = mc(_ @ _ @) /* C letter */ $.0i.4 = mc(_ @ @) /* D letter */ $.0i.5 = mc(@) /* E letter */ $.0i.6 = mc(@ @ _ @) /* F letter */ $.0i.7 = mc(_ _ @) /* G letter */ $.0i.8 = mc(@ @ @ @) /* H letter */ $.0i.9 = mc(@ @) /* I letter */ $.0i.10 = mc(@ _ _ _) /* J letter */ $.0i.11 = mc(_ @ _) /* K letter */ $.0i.12 = mc(@ _ @ @) /* L letter */ $.0i.13 = mc(_ _) /* M letter */ $.0i.14 = mc(_ @) /* N letter */ $.0i.15 = mc(_ _ _) /* O letter */ $.0i.16 = mc(@ _ _ @) /* P letter */ $.0i.17 = mc(_ _ @ _) /* Q letter */ $.0i.18 = mc(@ _ @) /* R letter */ $.0i.19 = mc(@ @ @) /* S letter */ $.0i.20 = mc(_) /* T letter */ $.0i.21 = mc(@ @ _) /* U letter */ $.0i.22 = mc(@ @ @ _) /* V letter */ $.0i.23 = mc(@ _ _) /* W letter */ $.0i.24 = mc(_ @ @ _) /* X letter */ $.0i.25 = mc(_ @ _ _) /* Y letter */ $.0i.26 = mc(_ _ @ @) /* Z letter */ $.0i.27 = mc(_ _ _ _ _) /* 0 digit */ $.0i.28 = mc(@ _ _ _ _) /* 1 digit */ $.0i.29 = mc(@ @ _ _ _) /* 2 digit */ $.0i.30 = mc(@ @ @ _ _) /* 3 digit */ $.0i.31 = mc(@ @ @ @ _) /* 4 digit */ $.0i.32 = mc(@ @ @ @ @) /* 5 digit */ $.0i.33 = mc(_ @ @ @ @) /* 6 digit */ $.0i.34 = mc(_ _ @ @ @) /* 7 digit */ $.0i.35 = mc(_ _ _ @ @) /* 8 digit */ $.0i.36 = mc(_ _ _ _ @) /* 9 digit */ $.0i.37 = mc(@ _ _ _ _ @) /* ' apostrophe */ $.0i.38 = mc(_ _ _ @ @ @) /* : colon */ $.0i.39 = mc(_ _ @ @ _ _) /* , comma */ $.0i.40 = mc(_ @ @ @ @ _) /* - minus or hyphen */ $.0i.41 = mc(_ @ _ _ @ _) /* ( left parenthesis */ $.0i.42 = mc(@ _ @ _ @ _) /* . period */ $.0i.43 = mc(@ @ _ _ @ @) /* ? question mark */ $.0i.44 = mc(_ @ _ @ _ @) /* ; semi-colon */ $.0i.45 = mc(_ @ @ _ @) /* / slash */ $.0i.46 = mc(@ @ _ _ @ _) /* _ underscrore */ $.0i.47 = mc(@ @ @ _ @ @ _) /* $ dollar sign */ $.0i.48 = mc(@ _ @ _ @ @) /* ! exclamation mark */ $.0i.49 = mc(_ _ _ @ @) /* ) right parenthesis*/ $.0i.50 = mc(_ @ @ @ _) /* = equal sign */ $.0i.51 = mc(@ _ _ @ _ @) /* @ comercial at */ $.0i.52 = mc(_ _ _ _ @) /* & ampersand */ $.0i.53 = mc(@ _ @ @ _ @) /* " double-quote */ $.0i.54 = mc(@ _ @ _ @) /* + plus sign */
do j=1 for length(@chars) $.0r.j = $.0i.j end /*j*/ /*use Int. for most chars.*/
$.0r.3 = mc(@ @ pause_ @) /* C, letter, railroad.*/ $.0r.6 = mc(@ long_ @) /* F, letter, railroad.*/ $.0r.10 = mc(_ @ _ @) /* J, letter, railroad.*/ $.0r.12 = mc(long_) /* L, letter, railroad.*/ $.0r.15 = mc(@ pause_ @) /* O, letter, railroad.*/ $.0r.16 = mc(@ @ @ @ @) /* P, letter, railroad.*/ $.0r.17 = mc(@ @ long_ @) /* Q, letter, railroad.*/ $.0r.18 = mc(@ pause_ @ @) /* R, letter, railroad.*/ $.0r.24 = mc(@ long_ @ @) /* X, letter, railroad.*/ $.0r.25 = mc(@ @ pause_ @ @) /* Y, letter, railroad.*/ $.0r.26 = mc(@ @ @ pause_ @) /* Z, letter, railroad.*/ $.0r.27 = mc(longer_) /* 0, digit, railroad.*/ $.0r.28 = mc(@ _ _ @) /* 1, digit, railroad.*/ $.0r.29 = mc(@ @ long_ @ @) /* 2, digit, railroad.*/ $.0r.30 = mc(@ @ @ long_ @) /* 3, digit, railroad.*/ $.0r.32 = mc(_ _ _) /* 5, digit, railroad.*/ $.0r.33 = mc(@ @ @ @ @ @) /* 6, digit, railroad.*/ $.0r.34 = mc(_ _ @ @) /* 7, digit, railroad.*/ $.0r.35 = mc(_ @ @ @ @) /* 8, digit, railroad.*/ $.0r.36 = mc(_ @ @ _) /* 9, digit, railroad.*/ $.0r.39 = mc(@ _ @ _) /* , comma, railroad.*/ $.0r.42 = mc(@ @ _ _ @ @) /* . period, railroad.*/ $.0r.43 = mc(_ @ @ _ @) /* ? question mark, railroad.*/ $.0r.48 = mc(_ _ _ @) /* ! exclamation mark, railroad.*/ $.0r.52 = mc(@ _ @ @ @) /* & ampersand, railroad.*/
if show then do jshow=1 for length(@chars)
call tt substr(@chars, jshow,1) $.0i.jshow
end /*jshow*/
from = '{}[]<>`\─' /*some chars not in Morse code.*/ into = "()()()'/─" /*translate chars──>Morse code.*/
newText = translate(plainText,into,from) /*translate some other chars. */ newText = space(newText, spaces) /*elide extraneous spaces. */ spread_ = copies(_b2, spread) /*construct the spread. */ spaces_ = copies(_b3, spaces) /* " " spaces. */
do jw=1 for w
aword=word(newText, jw)
if code\== then code = code || spaces_
pb=
do jc=1 for length(aword)
? = substr(aword, jc, 1)
idx = pos(?,@chars)
if idx==0 then code=code || pb || ?
else code=code || pb || $.morsetype.idx
pb=spread_
end /*jc*/
end /*jw*/
if split then code = translate(code,,_b3) if slice then code = translate(code,,_b2)
do jg=1 for words(code)
if jg\==1 & sound then call $tq ".Z="delayspace
glyph = word(code,jg)
cglyph = changestr(long_ , glyph, long)
cglyph = changestr(longer_, cglyph, longer)
call tt cglyph
call ss glyph
end /*jg*/
return unpsu(code)
/*─────────────────────────────SS subroutine────────────────────────────*/ ss: if \sound then return _s = unpsu(arg(1))
do js=1 for length(_s)
_c = substr(_s, js, 1)
if _c==' ' then call $tq ".Z="delayspace
if _c==dit then call $tq ".B=1 .BF="bf ".BD="dittime
if _c==dah then call $tq ".B=1 .BF="bf ".BD="dahtime
if _c==long_ then call $tq ".B=1 .BF="bf ".BD="longtime
if _c==longer_ then call $tq ".B=1 .BF="bf ".BD="longertime
call $tq ".Z="timedelay
end /*js*/
return
/*═════════════════════════════general 1-line subs════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════*/ !all:!!=!;!=space(!);upper !;call !fid;!nt=right(!var('OS'),2)=='NT';!cls=word('CLS VMFCLEAR CLRSCREEN',1+!cms+!tso*2);if arg(1)\==1 then return 0;if wordpos(!,'? ?SAMPLES ?AUTHOR ?FLOW')==0 then return 0;!call=']$H';call '$H' !fn !;!call=;return 1 !cal: if symbol('!CALL')\=="VAR" then !call=;return !call !env: !env='ENVIRONMENT';if !sys=='MSDOS'|!brexx|!r4|!roo then !env='SYSTEM';if !os2 then !env='OS2'!env;!ebcdic=1=='f0'x;return !fid: parse upper source !sys !fun !fid . 1 . . !fn !ft !fm .;call !sys;if !dos then do;_=lastpos('\',!fn);!fm=left(!fn,_);!fn=substr(!fn,_+1);parse var !fn !fn '.' !ft;end;return word(0 !fn !ft !fm,1+('0'arg(1))) !rex: parse upper version !ver !vernum !verdate .;!brexx='BY'==!vernum;!kexx='KEXX'==!ver;!pcrexx='REXX/PERSONAL'==!ver|'REXX/PC'==!ver;!r4='REXX-R4'==!ver;!regina='REXX-REGINA'==left(!ver,11);!roo='REXX-ROO'==!ver;call !env;return !sys: !cms=!sys=='CMS';!os2=!sys=='OS2';!tso=!sys=='TSO'|!sys=='MVS';!vse=!sys=='VSE';!dos=pos('DOS',!sys)\==0|pos('WIN',!sys)\==0|!sys=='CMD';call !rex;return !var: call !fid;if !kexx then return space(dosenv(arg(1)));return space(value(arg(1),,!env)) $fact!: procedure;parse arg x _ .;l=length(x);n=l-length(strip(x,'T',"!"));if n<=-n|_\==|arg()\==1 then return x;z=left(x,l-n);if z<0|\isint(z) then return x;return $fact(z,n) $fact!: procedure;parse arg x;l=length(x);n=l-length(strip(x,'T',"!"));z=left(x,l-n);if z<0|\datatype(z,'W') then return x;!=1;if n==1 then return $fact(z);do j=z to 2 by -n;!=!*j;end;return ! $fact: procedure;parse arg x _ .;arg ,n ! .;n=p(n 1);if \isint(n) then n=0;if x<-n|\isint(x)|n<1|_||!\==|arg()>2 then return x||copies("!",max(1,n));!=1;s=x//n;if s==0 then s=n;do j=s to x by n;!=!*j;end;return ! $sfxa: parse arg ,s,m;arg u,c;if pos(left(s,2),u)\==0 then do j=length(s) to compare(s,c)-1 by -1;if right(u,j)\==left(c,j) then iterate;_=left(u,length(u)-j);if isnum(_) then return m*_;leave;end;return arg(1) $sfxf: parse arg y;if right(y,1)=='!' then y=$fact!(y);if \isnum(y) then y=$sfxz();if isnum(y) then return y;return $sfxm(y) $sfxm: parse arg z;arg w;b=1000;if right(w,1)=='I' then do;z=shorten(z);w=z;upper w;b=1024;end;p=pos(right(w,1),'KMGTPEZYXWVU');if p==0 then return arg(1);n=shorten(z);r=num(n,f,1);if isnum(r) then return r*b**p;return arg(1) $sfxz: return $sfxa($sfxa($sfxa($sfxa($sfxa($sfxa(y,'PAIRs',2),'DOZens',12),'SCore',20),'GREATGRoss',1728),'GRoss',144),'GOOGOLs',1e100) $t: !call=']$T'; call "$T" tops arg(1); !call=; return $tq: call $t '.Q=1' arg(1); return abb: arg abbu;parse arg abb;return abbrev(abbu,_,abbl(abb)) abbl: return verify(arg(1)'a',@abc,'M')-1 abbn: parse arg abbn;return abb(abbn)|abb('NO'abbn) er: parse arg _1,_2;call '$ERR' "14"p(_1) p(word(_1,2) !fid(1)) _2;if _1<0 then return _1;exit result err: call er '-'arg(1),arg(2);return erx: call er '-'arg(1),arg(2);exit getdtfid:tfid=p(!var("TMP") !var('TEMP') homedrive()"\");if substr(tfid,2,1)==':'&substr(tfid,3,1)\=="\" then tfid=insert('\',t,2);return strip(tfid,'T',"\")'\'arg(1)'.'arg(2) gettfid:if tfid\== then return tfid;gfn=word(arg(1) !fn,1);gft=word(arg(2) 'ANS',1);tfid='TEMP';if !tso then tfid=gfn'.'gft;if !cms then tfid=gfn','gft",A4";if !dos then tfid=getdtfid(gfn,gft);return tfid halt: call er .1 homedrive:if symbol('HOMEDRIVE')\=="VAR" then homedrive=p(!var('HOMEDRIVE') 'C:');return homedrive int: int=num(arg(1),arg(2));if \isint(int) then call er 92,arg(1) arg(2);return int/1 ishex: return datatype(arg(1),'X') isint: return datatype(arg(1),'W') isnum: return datatype(arg(1),'N') mc: return translate(space(arg(1),betweens),_b1,' ') na: if arg(1)\== then call er 01,arg(2);parse var ops na ops;if na== then call er 35,_o;return na nai: return int(na(),_o) nan: return num(na(),_o) no: if arg(1)\== then call er 01,arg(2);return left(_,2)\=='NO' novalue:!sigl=sigl;call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) num: procedure;parse arg x .,f,q;if x== then return x;if isnum(x) then return x/1;x=space(translate(x,,','),0);if \isnum(x) then x=$sfxf(x);if isnum(x) then return x/1;if q==1 then return x;if q== then call er 53,x f;call erx 53,x f p: return word(arg(1),1) shorten:procedure;parse arg a,n;return left(a,max(0,length(a)-p(n 1))) syntax: !sigl=sigl;call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl) tell: if tops== then say arg(1); else call $t tops arg(1); return tt: if \quiet then call tell unpsu(arg(1));return unpsu: return translate(arg(1), , _b1 || _b2 || _b3) verchar:procedure;parse arg y,w;_=length(y);if _==1 then return y;if _==2 then do;if \ishex(y) then call er 40,y w;return x2c(y);end;if _==3 then do;if \int(y) then call er 92,y ',' w;return d2c(y);end;call er 55,y w</lang>