Rosetta Code

$T.REX: Difference between revisions

Page Discussion

$T.REX (view source)

Revision as of 03:05, 19 January 2021

9,611 bytes added ,  3 years ago
m
→‎$T.REX: elided duplicated code (from cut-n-paste).
m (→‎$T.REX: added a link to the SOUND.REX subroutine. -- ~~~~)
m (→‎$T.REX: elided duplicated code (from cut-n-paste).)
 
(15 intermediate revisions by 2 users not shown)
Line 1:
[[Category:REXX library routines]]
 
==$T.REX==
This is the   '''$T.REX'''   (REXX) program which is used by many other REXX programs to display error or informational message(s),
<br>some of the options follow)are:
::* &nbsp; in color(s) &nbsp; &nbsp; (if supported)
::* &nbsp; highlights (in color) parts (up to 8 unique parts) of the text &nbsp; &nbsp; (if supported)
::* &nbsp; write text to a file
::* &nbsp; breaks/splits the text into multiple lines
::* &nbsp; adds indentation
::* &nbsp; justifies the text: &nbsp; left/right/center/justify &nbsp; (autofillauto-fill)
::* &nbsp; add blank lines before and/or after the displaying of text
::* &nbsp; boxing (around) the text
::* &nbsp; add spacing around the text inside the box
::* &nbsp; only showing specific lines of the text messages
::* &nbsp; suppressing specific lines of the text messages
::* &nbsp; translation of certainspecific characters in the text
::* &nbsp; allowing other characters to be used for blanks
::* &nbsp; repeating a text
::* &nbsp; allows remarks in the text
::* &nbsp; writes the message, waits for a confirmation to proceed
::* &nbsp; delaying (waiting) after the text is displayed
::* &nbsp; showing a scale and/or a ruler above/below the text message(s)
::* &nbsp; supports hex/dec/bit strings
::* &nbsp; changing the case of the text
::* &nbsp; reverses the text
::* &nbsp; inverts the bits for certain characters
::* &nbsp; sounds alarm (beeps) after the text is displayed &nbsp; &nbsp; (if supported)
::* &nbsp; displays the text in reverse video (if supported)
::* &nbsp; displays the text in (big) block letters
::* &nbsp; clear the screen after or before the displaying of text
::* &nbsp; allows user-define option character, the default is &nbsp; '''.''' &nbsp; &nbsp; (period)
::* &nbsp; and many other options
 
<br>The help for the &nbsp; '''$T''' &nbsp; REXX program is included here ──► [[$T.HEL]].
 
<br><br>The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''$ERR''' &nbsp; REXX program which is used to display error messages (via &nbsp; '''$T''').
<br>The help for the &nbsp; '''$ERRT''' &nbsp; REXX program is included here &nbsp; ──► &nbsp; [[$ERRT.REXHEL]].
 
<br><br>The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''LINESIZE''' &nbsp; BIF &nbsp; which returns the terminals width (linesize).
 
<br>Some REXXes doen't have a &nbsp; '''LINESIZE''' &nbsp; BIF, so one is included here ──► [[LINESIZE.HEL]].
<br><br>The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''SCRSIZE$ERR''' &nbsp; BIFREXX program which returnsis theused terminalsto widthdisplay error messages (linesize)via and&nbsp; depth'''$T''').
<br>Some REXXes doen't have aThe &nbsp; '''SCRSIZE$ERR''' &nbsp; BIF,REXX so oneprogram is included here &nbsp; ──► &nbsp; [[SCRSIZE$ERR.HELREX]].
 
<br><br>The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''DELAY''' &nbsp; BIF which delays (sleeps) for a specified amount of seconds.
 
<br>Some REXXes doen't have a '''DELAY''' bif, so one is included here ──► [[DELAY.REX]].
<br><br>The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''SOUND$BLOCK''' &nbsp; BIFREXX program which producesis soundsused viato thegenerate PCtext speakerto display text in (big) blocked letters (via &nbsp; '''$T''').
<br>SomeThe REXXes&nbsp; doen't have a '''SOUND$BLOCK''' bif,&nbsp; soREXX oneprogram is included here &nbsp; ──► &nbsp; [[SOUND$BLOCK.REX]].
 
<br><br>REXX programs not included are &nbsp; '''$H''' &nbsp; which shows '''help''' and other documentation.
 
<lang rexx>/**/ trace off /* There be many dragons below. */
The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''LINESIZE''' &nbsp; BIF &nbsp; which returns the terminals width (linesize).
parse arg !
<br>Some REXXes don't have a &nbsp; '''LINESIZE''' &nbsp; BIF, &nbsp; so one is included here &nbsp; ──► &nbsp; [[LINESIZE.REX]].
if !all(0) then exit 0 /*help options and boilerplate.*/
 
 
The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''SCRSIZE''' &nbsp; BIF which returns the terminals width (linesize) and depth.
<br>Some REXXes don't have a &nbsp; '''SCRSIZE''' &nbsp; BIF, &nbsp; so one is included here &nbsp; ──► &nbsp; [[SCRSIZE.REX]].
 
 
The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''DELAY''' &nbsp; BIF which delays (sleeps) for a specified amount of seconds.
<br>Some REXXes don't have a &nbsp; '''DELAY''' &nbsp; BIF, &nbsp; so one is included here &nbsp; ──► &nbsp; [[DELAY.REX]].
 
 
The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''SOUND''' &nbsp; BIF which produces sounds via the PC speaker.
<br>Some REXXes don't have a &nbsp; '''SOUND''' &nbsp; BIF, &nbsp; so one is included here &nbsp; ──► &nbsp; [[SOUND.REX]].
 
 
REXX programs not included are &nbsp; '''$H''' &nbsp; which shows '''help''' and other documentation.
<lang rexx>/*REXX program to perform various functions in displaying text to the console (screen). */
 
/* There be many dragons below. */
 
trace off
 
parse arg ! /*obtain original arguments. */
if !all(0) then exit 0 /*test request for documentation.*/
 
zz = !! /*save the original arguments. */
if !cms then address '' /*if CMS, then use fast ADDRESS. */
 
signal on halt /*be able to handle a HALT. */
signal on noValue /*catch REXX vars with noValue. */
signal on syntax /*catch REXX syntax errors. */
 
zznumeric digits 300 = !! /*save abe copyable ofto originalhandle args.some big 'uns*/
if !cms then address ''
signal on halt /*be able to handle a HALT. */
signal on novalue /*catch REXX vars with noValue. */
signal on syntax /*catch REXX syntax errors. */
numeric digits 300 /*be able to handle some big 'uns*/
 
hues=space( 'BLACK 0;30', /*define some colors for DOS. */
'BROWN 0;33',
'DEFAULT 1;37',
Line 64 ⟶ 91:
'YELLOW 1;33',
'WHITE 1;37',
'BRITE 1;37') /*colors for DOS via ANSI.SYS */
 
_= /*(below) set some vars ──> NULL */
parse var _ ?. @ color. colorC. ahics ehics hold lz more onlyo onlys,
scr0 shics VMout VScolor VSdisp x1 x2
 
@abc = 'abcdefghijklmnopqrstuvwxyz'; @abcU = @abc; upper @abcU
@abcU = @abc
upper @abcU
 
#ms = 0
?.a = 0
?.b = 0
?.block = 0
?.e = 0
?.end = 0
?.i = 0
?.ks = 0
?.L = 0
?.p = 0
?.q = 0
?.r = 0
?.ruler = 0
?.s = 0
?.scale = 0
?.ts = 0
?.x = 0
?.z = 0
boxing = 0
highL = 0
LLd = 0
LLk = 0
LLx = 0
maxhic = 0
 
## = 1
Line 102 ⟶ 131:
?.t = 1
 
?.bd = .2
?.bf = 800
?.bs = 2
?.o = 9999
?.rulerb = ' '
?.scaleb = ' '
?.scaled = '.'
?.scalep = '+'
?.use = '.'
esc = '1b'x"["
 
his= 'H() H{} H[] H<> H≤≥ H«» H/\"'
#his= words(his)
do jh=1 for 7
hh.jh=substr(word(his,jh),2)
end /*jh*/
 
boxCHdo jh=1 '+-+|+-+|' for /*define some boxing characters. */#his
hh.jh= substr( word(his, jh), 2)
if !ebcdic then boxCH = 'acbfbcfabbbfabfa'x /*¼┐╝·╗┐½· <──single box.*/
end /*jh*/
if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box.*/
 
ifcolorSupport= !pcrexx | !r4 | !roo then do /*use pre-saved color values. /*colors are supported by these. */
 
_=translate(!var('SCREEN'), ,";,") /*envVar*/
boxCH = '+-+|+-+|' if \datatype(space(_,0), "W") then _='36 40' /*define some boxing characters. */
if !ebcdic then boxCH = 'acbfbcfabbbfabfa'x /*¼┐╝·╗┐½· <──single box. */
scr0=esc || translate(0 _, ';', " ")'m'
if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box. colorC.0=scr0 */
 
colorC.1=esc"1;33m"
if colorSupport then do end /*use pre-saved color values. */
_= translate( !var('SCREEN'), , ";,") /*envVar.*/
do jz=1 while zz\==''
if \datatype( space(_, 0), "W") then _= '36 40'
if ?.end==1 | pos('=',zz)==0 | pos(" "?.use,' 'zz)==0 then do
scr0= esc || translate(0 _, ';', " @=@ zz")'m'
colorC.0= leavescr0
colorC.1= endesc"1;33m"
end
 
 
 
do jz=1 while zz\==''
if ?.end==1 | pos('=',zz)==0 | pos(" "?.use,' 'zz)==0 then do
@= @ zz
leave
end
if left(zz,1)==' ' then lz=lz" "
parse var zz yy1 2 yy2 3 1 yy ' ' zz
 
if yy1==?.use & pos('=',yy)\==0 & datatype(yy2,"U") then
do 1
parse var yy 2 _ "=" dotv 2 _1 3
if datatype(_,'U') then
do
L1=length(_)==1
if L1 then do
if _=='H' then ?.hi.1=dotv
else ?._=dotv
iterate jz
end
else select
when _=='BIN' then yy=valn("'"dotv"'B",'BIN',"B")
when _=='BOX' then do
if dotv=="" then ?.BOX=boxCH
else ?.BOX=dotv
iterate jz
end
when _=='DEC' then yy=valn("'"dotv"'D",'DEC',"D")
when _=='INV' then yy=.inv(dotv)
when _=='HEX' then yy=valn("'"dotv"'X",'HEX',"X")
when _=='USE' then do
dotv=tb(dotv,"USE",'.')
iterate jz
end
otherwise ?._=dotv; iterate jz
end /*select*/
end
 
if yy1==?.use & pos('=',yy)\==0 & datatype(yy2, "U") then
if _1=='H' then do
do 1 _ /*process "dot" options if has =wordpos(_,his).*/
parse var yy 2 _ "=" dotv 2 _1 3
 
if datatype(_, 'U') then /*is the option in uppercase? */
if length(_)==1 then do /*is the option just one letter? */
if _=='H' then ?.hi.1= dotv
else ?._= dotv
iterate jz
end
else select /*option is more then one letter.*/
when _=='BIN' then yy= valn("'"dotv"'B", 'BIN', "B")
when _=='BOX' then do
if dotv=="" then ?.BOX= boxCH
else ?.BOX= dotv
iterate jz
end
when _=='DEC' then yy= valn("'"dotv"'D", 'DEC', "D")
when _=='INV' then yy= .inv(dotv)
when _=='HEX' then yy= valn("'"dotv"'X",' HEX', "X")
when _=='USE' then do
dotv= tb(dotv, "USE", .)
iterate jz
end
otherwise ?._= dotv
iterate jz
end /*select*/
 
 
if _1=='H' then do /*special handling for: .Hxx= */
_= wordpos(_, his) /*see the HIS variable above.*/
if _\==0 then do
?.hi._= dotv
iterate jz
end
end
end /*do 1*/
 
 
if @=='' then @=lz || yy
if @=='' then @= lz else @=@|| yy
else @= @ yy
lz=
end /*jz*/
 
 
if left(@,1)==' ' then @=substr(@,2) /*handle this special case. */
 
if left(@, 1)==' ' then @= substr(@, 2) /*handle this special case. */
 
if ?.a\==0 then call .a
Line 186 ⟶ 226:
if ?.block\==0 then call .block
if ?.c\=='' then call .c
hue.1=colorC.0
if ?.d\=='' then call .d
if ?.e\==0 then call wn 'E',0,99,sd()
?.eb= tb(?.eb, 'EB')
if ?.ef\=='' then call .ef
if ?.f\=='' then call .f
 
do _j=1 for 7#his
_= ?.hi._j
if _\=='' & \!regina then do
call colors _, "H"hh._j, _j
highL= 1
end
end /*_j*/
 
hue.1= colorC.0
 
if ?.i\==0 then do
call wn 'I',0,sw()
?.ib= tb(?.ib, 'IB')
end
 
if ?.i\==0 then do; call wn 'I',0,sw(); ?.ib=tb(?.ib,'IB'); end
if ?.j\=='' then call .j
if ?.k\=='' then ?.k = valn(?.k, "K")
if ?.kd\=='' then ?.kd= valn(?.kd, "KD")
if ?.k\=='' then if ?.kd\=="" then call er 61, '.K= .KD='
if ?.ks\==0 then call .ks
if ?.L\==0 then call .L
if ?.o\==9999 then call .o
 
if ?.p\==0 then do; call wn 'P',-99,99; ?.pb=tb(?.pb,'PB'); end
if ?.p\==0 then do
call wn 'P',-99,99
?.pb= tb(?.pb, 'PB')
end
 
if ?.q\==0 then call wn 'Q',0,1
if ?.r\==0 then call wn "R",0,99; ?.r=?.r+1
?.r= ?.r + 1
if ?.ruler\==0 then call .ruler
if ?.s\==0 then call .s; ?.s=?.s+1
?.s= ?.s + 1
if ?.scale\==0 then call .scale
if ?.t\==1 then call .t
if ?.u\=='' then call .u
?.ub= tb(?.ub,'UB')
if ?.ut\=='' then call .ut
if ?.v\=='' then call .v
?.xb= tb(?.xb,'XB')
if ?.z\==0 then call wn 'Z',0,99,,"N"
if ?.box\=='' then call .box
if highL then call highLight
indent= copies(?.ib,?.i)
if ?.x\==0 then call .x
@= copies(@, ?.r)
ll= length(@)
if ?.ub\==' ' then @= translate(@, ?.ub, " ")
_= length(?.ut) % 2
if _\==0 then @= translate(@, right(?.ut, _), left(?.ut, _) )
tx.1= @
xk= ?.k || ?.kd
if xk\=='' then call .xk
if LLk\==0 then LL= LLk
 
if ?.block\==0 then tLL= 12 + max(LL - 1, 0) * (12 + ?.bs)
else tLL= LL
 
bline= strip(indent || x1 || copies(?.ab, tLL+4*boxing)x2, 'T')
 
if boxing then call ms bx.1 || copies(bx.2, LLx + tLL + 2)bx.3
caLL VEReb ?.e,?.eb
 
 
do jt=1 for ?.t
Line 250 ⟶ 303:
if jj\==1 then call VEReb ?.ks,?.ksb
 
if boxing then _= left(tx.jj, tLL)
else _= tx.jj
 
if ?.v=='R' then _= reverse(_)
 
if ?.u\=='' then select
when ?.u=='A' then nop
when ?.u=='U' then upper _
when ?.u=='L' then _= lower(_)
when ?.u=='F' then _= proper(_)
when ?.u=='W' then do
__=
do jw=1 for words(_)
__= __ proper( word(_, jw) )
end /*jw*/
 
_= strip(__)
end
end /*select*/
 
if ?.block==0 then call tellIt _
else call blocker
end /*jj*/
end /*jt*/
 
 
call VEReb ?.e,?.eb
if boxing then call ms bx.7 || copies(bx.6, LLx + tLL + 2)bx.5
call beeps ?.b
call .p
Line 282 ⟶ 336:
if ?.scale<0 then call inches ?.scale,1
 
select
select /* <══════════════════════════where the rubber meets the road.*/
when highL then call sayHighlight
when \highL & (?.c=='BRITE' | ?.c=="BRIGHT") then call sayBright
when ?.L\==0 then call sayAline
otherwise call sayNline
end /*select*/
 
if ?.c\=='' then call VMcolor VMout,space(VScolor VSdisp)
Line 294 ⟶ 348:
if ?.ruler>0 then call inches ?.ruler,0
if ?.scale>0 then call inches ?.scale,1
_= abs(?.a)
 
if _==99 & \?.q then !cls
else do min(99, _)
call wit bline
end /*min(...···*/
 
if ?.w\=='' then call .w
 
if !pcrexx then if ?.q & LLd>79 then if LLd>sw() then say
 
/*(above) PC-REXX bug: wrapped lines are */
/* overwritten during cleanup. /*(above) PC-REXX bug: wrapped lines are*/
/* overwritten during cleanup. */
return 0
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.B subroutine───────────────────────*/
.ba: call wn 'BA',-99,99,sd() /*B is for beeps (sounds). */
?.ab= tb(?.ab, 'AB')
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if ?.bd\==.2 then do
.b: call wn _=translate(?.bd'B',-99,'99,'sd()
__=_
do while __\==''
parse var __ ?.bd __
call wn 'BD', .1, 9, ,"N"
end /*while*/
?.bd=_
end
 
if ?.bfbd\==800.2 then do
_= translate(?.bfbd, , ',')
__= _
do while __\==''
parse var __ ?.bfbd __
call wn 'BFBD', .1, 200009, ,"N"
end /*while*/
?.bfbd= _
end
return
 
if ?.bf\==800 then do
/*──────────────────────────────────.BLOCK subroutine───────────────────*/
_= translate(?.bf, , ',')
.block: call wn 'BLOCK',-12,12
if ?.bs\__==2 then call wn 'BS', -12, sw()_
if ?.bc\=='' then ?.bc = tb(?.bc, "BC") do while __\==''
parse var __ ?.bf __
?.bb=tb(?.bb,'BB')
call wn 'BF', 1, 20000
return
end /*while*/
?.bf= _
end
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.BOX subroutine─────────────────────*/
.block: call wn 'BLOCK',-12,12
.box: _=?.box; upper _
if _=='*NONE*' then ?.box=
boxing= ?.box\==''
if \boxing then return
 
if ?.bs\==2 then call wn 'BS', -12, sw()
if _=='SINGLELINE' then _=boxCH
if length(_)>8 if then?.bc\=='' call erthen 30, '?.BOXbc ='_ "boxcharacterstb(?.bc, 1 8"BC")
?.box=left(_,8,right(_,1))
do _=1 for 8
bx._=substr(?.box,_,1)
end /*_*/
_=verify(@,' ')-1
if _>0 then @=@ || copies(" ",ldb)
return
 
?.bb= tb(?.bb, 'BB')
/*──────────────────────────────────.C subroutine───────────────────────*/
return
.c: call colors ?.c,'C',0
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if !cms then do
.box: _= ?.box
call cp 'QUERY SCREEN',1
upper parse var cp.1 "VMOUT" VMout_
if _=='*NONE*'QUERY VSCREEN CMSthen ALL(LIFO'?.box=
boxing= ?.box\==''
if rc==0 then pull "(" . . VScolor VSdisp .
if ?.c=='BRITE'\boxing then call VMcolor "DEFAULT NONE"return
else call VMcolor color.0 ?.d, color.0 ?.d
end
 
if _=='SINGLELINE' then _= boxCH
if !regina then ?.c= /*Regina can't handle colors. */
if length(_)>8 then call er 30, '.BOX='_ "boxcharacters 1 8"
return
 
?.box= left(_, 8, right(_,1) )
/*──────────────────────────────────.D subroutine───────────────────────*/
.d: upper ?.d
_ = ?.d
 
do _=1 for 8
if \(abbrev('BRITE',_,3) |,
bx._= substr(?.box, _, 1)
abbrev("BRIGHT",_,3) |,
end /*_*/
abbrev('HIGHLIGHT',_) |,
abbrev("NONE",_,3) |,
abbrev('REVVIDEO',_,3) |,
abbrev("UNDERLINE",_,3)) then call er 55, _ ".D="
 
_= verify(@, ' ') - 1
if !regina then ?.d= /*Regina can't handle DISP's. */
else if left(_,1)=='H'>0 then @= @ || thencopies(" ", highL=1_)
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.EF subroutine──────────────────────*/
ef.c: if ?.f\=='' then call ercolors 61?.c, '.F= .EF=C', /*conflicting options.*/0
?.f = ?.ef
return
 
if !cms then do
/*──────────────────────────────────.F subroutine───────────────────────*/
.f: _=?.f call cp 'QUERY /*File where the text is written.*/SCREEN',1
parse var cp.1 "VMOUT" VMout
if !cms then do
_=translate(_, , '/,') /*try to translate to 'QUERY VSCREEN CMS format.*/ALL (LIFO'
if words(_)>3rc==0 then callpull "(" . . erVScolor 10,VSdisp ?.f
?.f = _ word(subword(_,2) !fn,1) word(subword(_,3) 'A1',1)
end
 
if ?.c=='BRITE' then call VMcolor "DEFAULT NONE"
__=lastpos("\",_)
else call VMcolor color.0 ?.d, color.0 ?.d
if !dos & ?.ef=='' & __\==0 then call $mkdir left(_,__)
end
return
 
if \colorSupport then ?.c=
/*──────────────────────────────────.INV subroutine─────────────────────*/
return
.inv: return x2c( b2x( translate( x2b( c2x( arg(1) ) ), 01, 10) ) )
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.J subroutine───────────────────────*/
.d: upper ?.d
.j: upper ?.j /*Justify (or not) the text. */
_= ?.d
if ?.j=='' then ?.j = 'N' /*Justify (or not) the text. */
else ?.j=left(?.j,1) /*just use the first letter of .J*/
 
if \(abbrev('BRITE', _,3) |,
if pos(?.j,"ACJLNR")==0 then call er 55, ?.j '.J='
if ?.j=='A' abbrev("BRIGHT", then ?.j= substr(copies('LRC' _,303) |,random(1,90),1)
abbrev('HIGHLIGHT', _) |,
abbrev("NONE", _,3) |,
abbrev('REVVIDEO', _,3) |,
abbrev("UNDERLINE", _,3) ) then call er 55, _ ".D="
 
if !regina then ?.jbd=tb(?.jb,'JB') /*whileRegina wecan're here,t handle JBDISP's. */
else if left(_, 1)=='H' then highL= 1
return
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.KS subroutine──────────────────────*/
ef: if ?.f\=='' then call er 61, '.F= .EF=' /*conflicting options.*/
.ks: call wn 'KS', 0, 99, sw()
?.f = ?.ef
?.ksb = tb(?.ksb, 'KSB') /*blank lines between karate chop*/
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.L subroutine───────────────────────*/
.Lf: upper _= ?.Lf /*Line(s)File forwhere the text is shownwritten. */
if !cms then do
'$QWHAT DSC _= translate(_, , '/,') /*try to translate to CMS format.*/
if rc==4words(_)>3 then call er 10, ?.L=0f
end ?.f= _ word(subword(_, 2) !fn, 1) word( subword(_, 3) 'A1', 1)
end
 
__= lastpos("\", _)
if ?.L=='CMSG' then ?.L="*"
if !dos & ?.ef=='' & __\==0 then call $mkdir left(_, __)
call wn 'L',-sd(),sd()
if ?.L<0 then ?.L=sd()-?.Lreturn
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.O subroutine───────────────────────*/
.inv: return x2c( b2x( translate( x2b( c2x( arg(1) ) ), 01, 10) ) )
.o: call wn 'O',-999,999,9999
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if ?.o<0 then do
.j: upper onlyo=-?.oj
if ?.j=='' then ?.j= 'N' /*Justify (or not) the text. */
?.o=9999
else ?.j= left(?.j,1) /*just use the first letter of .J*/
end
return
 
if pos(?.j, "ACJLNR")==0 then call er 55, ?.j '.J='
/*──────────────────────────────────.P subroutine───────────────────────*/
.p: if ?.qj== 'A' then return then ?.j= substr( /*Post copies(writting'LRC', 30), blankrandom(1, lines.90), */1)
_=?.p
 
?.jb= tb(?.jb, 'JB') /*while we're here, handle JB. */
if _>98 |,
_<0 then do 1 return
if !cms & _>9998 then call CPmore
!cls
if \!cms then leave /*1*/
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if _>9998 & more\=='' then call CP 'TERMINAL MORE' more
.ks: call wn 'KS', 0, 99, sw()
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold
?.ksb = tb(?.ksb, 'KSB') /*blank lines between karate chop*/
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold
end /*1*/return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
do abs(_) while _<99
.L: upper ?.L /*Line(s) for the text is shown. */
call wit bline
end /*abs*/
do _=1 to -?.a
call wit bline
end /*_*/
return
 
if !cms then do
/*──────────────────────────────────.RULER subroutine───────────────────*/
'$QWHAT DSC'
.ruler: call wn 'RULER', -sw(), sw() /*RULER draws a "ruler" line. */
if rc==4 then ?.L= 0
?.rulerb = tb(?.rulerb, 'RULERB')
end
return
 
if ?.L=='CMSG' then ?.L= "*"
/*──────────────────────────────────.S subroutine───────────────────────*/
.s: call wn "S", -999, 999, 999 /*Skip (or suppress) line(s). */
 
call wn 'L',-sd(),sd()
if ?.s<0 then do
if left(?.o,1)=='-' then /*check for conflicting options*/
call er 61,"O="?.o 'S='?.s "(both can't be negative)"
onlys = -?.s
?.s = 0
end
 
if ?.L<0 then ?.L= sd() - ?.L
if left(?.o,1)=="-" & left(?.s,1)=='-' then
return
call er 61,"O="?.o 'S='?.s "(both can't be negative)"
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.SCALE subroutine───────────────────*/
.scaleo: call wn 'SCALEO', -sw()999, sw() /*SCALE draws a "scale" line. */999,9999
?.scaleb = tb(?.scaleb, 'SCALEB')
?.scaled = tb(?.scaled, 'SCALED', ".")
?.scalep = tb(?.scalep, 'SCALEP', "+")
return
 
if ?.o<0 then do
/*──────────────────────────────────.T subroutine───────────────────────*/
.t: call wn 'T', 0, 99 /*Times the textonlyo= is written-?. */o
?.o= 9999
if ?.ts\==0 then call wn 'TS', 0, 99
?.tsb = tb(?.tsb, 'TSB') end
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.U subroutine───────────────────────*/
.up: upperif ?.uq then return /*handlePost uppercasing(writting) textblank partslines. */
?.u _= left(?.u, 1)p
if pos(?.u, " AFLUW")==0 then call er 55, ?.u '.U='
if ?.u==' ' | ?.u=='A' then ?.u=
return
 
if _>98 |,
/*──────────────────────────────────.UT subroutine──────────────────────*/
_<0 then do 1
.ut: call wn 'T', 0, 99 /*Times the text is written. */
if !cms & _>9998 then call CPmore
?.ut=valn(?.ut, "UT")
!cls
if \!cms then leave /*1*/
 
if length(?.ut)//2_>9998 & more\==1'' then call CP 'TERMINAL MORE' more
call er 30,?.ut if _>99999998 & hold\==''translate-characters an-even-number-of then call CP 'TERMINAL HOLD' hold
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold
return
end /*1*/
 
do abs(_) while _<99
/*──────────────────────────────────.V subroutine───────────────────────*/
call wit bline
.v: upper ?.v /*video mode, Normal -or- Reverse*/
?.v=left(?.v, 1) end /*abs*/
if pos(?.v, " NR")==0 then call er 55, ?.v '.V do _='1 to -?.a
if ?.v==' ' | ?.v=='N' then ?.v= call wit bline
end /*_*/
return
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.W subroutine───────────────────────*/
.ruler: call wn 'RULER', -sw(), sw() /*RULER draws a "ruler" line. */
.w: if ?.q then return
if ?.wb\rulerb=='' then ?.wb=tb(?.wbrulerb, 'WBRULERB')
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
ww=translate(?.w,,"_")
.s: call wn "S", -999, 999, 999 /*Skip (or suppress) line(s). */
if ww='dd'x then ww = "press any key to continue ..."
if ww='de'x then ww = "press the ENTER key to continue ..."
call '$T' ".C=yel" translate(ww,?.wb,' ')
if ww='dd'x then call inkey
if ww='de'x then pull external
return
 
if ?.s<0 then do
/*──────────────────────────────────.X subroutine───────────────────────*/
if left(?.o, 1)=='-' then /*check for conflicting options*/
.x: call wn 'X', -sw(), sw()
x2 = copies( call er 61,"O="?.xb,o abs('S='?.x)s "(both can't be negative)"
if ?.x<0 then x1 onlys =x2 -?.s
LLx = length(x1 || x2) ?.s = 0
end
return
 
if left(?.o, 1)=="-" & left(?.s, 1)=='-' then
/*──────────────────────────────────.XK subroutine──────────────────────*/
call er 61,"O="?.o 'S='?.s "(both can't be negative)"
.xk: do ##=1
parse var @ _ (xk) @return
if _=='' & @=="" then leave
tx.## = _
if @\=='' then tx.## = tx.## || ?.k
tx.## = strip(tx.##)
LLk = max(LLk, length(tx.##))
end /*##*/
##=##-1
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────.Z subroutine───────────────────────*/
.zscale: call wn 'SCALE', _z=word-sw(arg(1) ?.z, 1sw() /*snoreSCALE subroutine:draws a zzzzzz... "scale" line. */
if _z=0 then return
if !cms then call cp 'SLEEP' _z "SEC"
if !dos then call delay _z
return
 
?.scaleb= tb(?.scaleb, 'SCALEB')
/*──────────────────────────────────BEEPS subroutine────────────────────*/
?.scaled= tb(?.scaled, 'SCALED', .)
beeps: if \!dos & !pcrexx then return /*can this OS handle sounds? */
?.scalep= tb(?.scalep, 'SCALEP', "+")
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
do jb=1 for abs(arg(1))
.t: call wn 'T', 0, 99 /*Times the text is written. */
if jb\==1 then call delay .1
if ?.ts\==0 then call wn 'TS', 0, 99
?.tsb= tb(?.tsb, 'TSB')
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
do jb_=1 for words(?.bf)
.u: upper ?.u /*handle uppercasing text parts. */
call sound word(?.bf, jb_), word(word(?.bd,jb_) .2,1)
?.u= left(?.u, end /*jb_*/1)
if pos(?.u, " AFLUW")==0 then call er 55, ?.u '.U='
if ?.u==' ' | ?.u=='A' then ?.u=
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
end /*jb */
.ut: call wn 'T', 0, 99 /*Times the text is written. */
return
?.ut= valn(?.ut, "UT")
 
if length(?.ut) // 2 == 1 then
/*──────────────────────────────────BLOCKER subroutine──────────────────*/
blocker: do jc=1 for LL call er 30,?.ut /*process'translate-characters some blocked characters*/an-even-number-of'
return
chbit.jc = $block(substr(_, jc, 1))
end /*jc*/
bcl = ?.block
bcs = 1
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if bcl<0 then do
.v: upper ?.v /*video mode, Normal -or- Reverse*/
bcl=-bcl
?.v= left(?.v, bcs=3*bcl-21)
if pos(?.v, " NR")==0 then call ender 55, ?.v '.V='
if ?.v==' ' | ?.v=='N' then ?.v=
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
.w: if ?.q then return
if ?.wb\=='' then ?.wb= tb(?.wb, 'WB')
ww= translate(?.w, , "_")
 
if ww='dd'x then ww = "press any key to continue ..."
if ww='de'x then ww = "press the ENTER key to continue ..."
 
call '$T' ".C=yel" translate(ww,?.wb,' ')
 
if ww='dd'x then call inkey
if ww='de'x then pull external
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
.x: call wn 'X', -sw(), sw()
x2= copies(?.xb, abs(?.x) )
if ?.x<0 then x1= x2
LLx= length(x1 || x2)
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
.xk: do ##=1
parse var @ _ (xk) @
if _=='' & @=="" then leave
tx.##= _
if @\=='' then tx.## = tx.## || ?.k
tx.##= strip(tx.##)
LLk= max(LLk, length(tx.##))
end /*##*/
 
##= ## - 1
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
.z: _z= word( arg(1) ?.z, 1) /*snore subroutine: zzzzzz... */
if _z=0 then return
if !cms then call cp 'SLEEP' _z "SEC"
if !dos then call delay _z
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
beeps: if \!dos & !pcrexx then return /*can this OS handle sounds? */
 
do jb=1 for abs( arg(1) )
if jb\==1 then call delay .1
 
do jb_=1 for words(?.bf)
call sound word(?.bf, jb_), word( word(?.bd, jb_) .2, 1)
end /*jb_*/
end /*jb */
 
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
blocker: do jc=1 for LL /*process some blocked characters*/
chbit.jc= $block(substr(_, jc, 1) )
end /*jc*/
 
bcl= ?.block
bcs= 1
 
if bcl<0 then do
bcl= -bcl
bcs= 3 * bcl - 2
end
 
if _=='' then _=' '
tbc = ?.bc
if tbc=='' then tbc=_
tbc = left( copies(tbc, 1 + sw() % length(tbc) ), sw() )
 
do jl=bcs to 3*bcl by 3
_ = copies(?.bb, max(1, 12 * LL + ?.bs * LL - ?.bs) )
bix = 1
do jo=1 for LL
_ = overlay( translate( x2b( substr(chbit.jo, jl, 3)),,
substr(tbc, jo, 1)?.bb, 10), _, bix)
bix = max(1, bix + ?.bs + 12)
end /*jo*/
call tellIt _
end /*jl*/
 
call tellIt _
return
end /*jl*/
 
return
/*──────────────────────────────────COLORS subroutine───────────────────*/
colors: arg hue,__,cc#,cc /*verify/handle synonymous colors*/
dark = left(hue,4)=='DARK'
if dark then hue = substr(hue,5)
if hue=='BRITE' | hue=="BRIGHT" then hue = 'WHITE'
if left(hue,5)=='BRITE' then hue = substr(hue,6)
if left(hue,6)=="BRIGHT" then hue = substr(hue,7)
if abbrev('MAGENTA',hue,3) then hue = "PINK"
if abbrev('CYAN' ,hue,3) then hue = "TURQUOIS"
if hue=='GREY' then hue = "GRAY"
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
do jj=1 to words(hues) by 2
colors: arg hue,__,cc#,cc /*verify/handle synonymous colors*/
ahue=word(hues,jj)
if abbrev dark = left(ahue,hue,34) then do=='DARK'
if dark cc then hue =word substr(hueshue,jj+1 5)
if hue=='BRITE' | hue=="BRIGHT" then hue = hue=ahue'WHITE'
if left(hue, 5)=='BRITE' then hue = substr(hue, leave6)
if left(hue, 6)=="BRIGHT" then hue = substr(hue, end7)
if abbrev('MAGENTA', hue, 3) then hue = "PINK"
end /*jj*/
if abbrev('CYAN' , hue, 3) then hue = "TURQUOIS"
if hue=='GREY' then hue = "GRAY"
 
if cc=='' do jj=1 to words(hues) by then call er 50, "color" '.'__"="hue2
ahue= word(hues, jj)
if dark & left(cc,2)=='1;' then cc="0"substr(cc,2)
if abbrev(ahue, hue, 3) then do
cc= word(hues, jj + 1)
hue= ahue
leave
end
end /*jj*/
 
if cc=='' then call er 50, "color" '.'__"="hue
if !cms then do
if dark & left(cc, if hue2)=='GRAY1;' | hue=then cc= "BLACK0"substr(cc, then hue='WHITE'2)
if hue="BROWN" then hue='YELLOW'
end
 
if !cms then do
color.cc# = hue
if hue='GRAY' | hue=="BLACK" then hue= 'WHITE'
colorC.cc# = esc || cc'm'
if hue="BROWN" then hue= 'YELLOW'
return
end
 
color.cc# = hue
/*──────────────────────────────────CPMORE subroutine───────────────────*/
colorC.cc# = esc || cc'm'
cpMore: call cp 'QUERY TERM', 9 /*parse CP TERMINAL for MORE,HOLD*/
__=return
do jj=1 for cp.0
__=__ cp.jj
end /*jj*/
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
parse upper var __ 'MORE' more ',' 1 'HOLD' hold ','
cpMore: call cp 'QUERY TERM', 9 if _>9998 & more\=='' then call cp 'TERMINAL MORE 0/*parse 0'CP TERMINAL for MORE,HOLD*/
__=
if _>99999998 & hold\=='' then call cp 'TERMINAL HOLD OFF'
do jj=1 for cp.0
return
__= __ cp.jj
end /*jj*/
 
parse upper var __ 'MORE' more ',' 1 'HOLD' hold ','
/*──────────────────────────────────DSAY subroutine─────────────────────*/
dsay: if ?.q_>9998 then return & more\=='' then call /*docp SAY subroutine,'TERMINAL writeMORE to0 scr*/0'
if _>99999998 & hold\=='' dsay_ =then strip(translate(arg(1),call , '0'x),cp 'TTERMINAL HOLD OFF')
say dsay_return
LLd = length(dsay_) /*length of last line displayed. */
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────HIGHLIGHT subroutine────────────────*/
dsay: if ?.q then return /*do SAY subroutine, write to scr*/
highLight: do _=1 for 7
dsay_= strip( translate( arg(1), hhl._, '0'x), = color._\=='T')
say hics._ = left(hh._,1)dsay_
LLd= length(dsay_) /*length of last line displayed. */
hice._ = right(hh._,1)
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if hhl._ then do
highLight: do _=1 for 7
minhic= min(_,minhic); shics= shics || hics._
maxhic= max(hhl._,maxhic); ehics= ehics || hicecolor._\==''
hics._ = left(hh._, end1)
end hice._ /*= right(hh._*/, 1)
 
if hhl._ then do
ahics=shics || ehics
minhic= min(_, minhic); shics= shics || hics._
return
maxhic= max(_, maxhic); ehics= ehics || hice._
end
end /*_*/
 
ahics= shics || ehics
/*──────────────────────────────────HUE subroutine──────────────────────*/
hue: hue#=max(1, hue#+arg(1))return
__=arg(2)
if __\=='' then hue.hue#=__
_=
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────INCHES Subroutine───────────────────*/
hue: hue#= max(1, hue# + arg(1) )
inches: /*handle RULER and SCALE stuff.*/
__= arg(2)
_ = kw('RULERB') kw('SCALEB') kw('SCALEP') kw('SCALED')
if __\=='' then hue.hue#= __
_=
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if arg(2) then _=$scale(?.scale _ 'Q')
inches: _= kw('RULERB') kw('SCALEB') kw('SCALEP') kw('SCALED')
else _=$scale(?.ruler 'RULE' _ 'Q')
/*handle RULER and SCALE stuff.*/
if arg(2) then _= $scale(?.scale _ 'Q')
else _= $scale(?.ruler 'RULE' _ "Q")
 
parse var _ _.1 '9'x _.2 '9'x _.3
 
do jk=1 for 3
_= _.jk
if _\=='' then call wit _
end /*jk*/
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────MS subroutine───────────────────────*/
ms: #ms= #ms + 1 /*justification and indentation. */
parse arg _i
 
select
when ?.j=='' then nop
when ?.N=='N' then nop
when length(_i)>=sw()-1 then nop
when ?.j=='C' then _i = centre(_i, sw() - 1, ?.jb)
when ?.j=='L' then _i = strip(_i)
when ?.j=='R' then _i = right( strip(_i, "T"), sw() - 1)
when ?.j=='J' then _i = justify(_i, sw() - 1, ?.jb)
end /*select*/
 
mm.#ms= strip(indent || _i, 'T')
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────SAYALINE subroutine──────────────────*/
sayAline:
do jj=?.s to #ms for ?.o
if skp() then iterate
 
do jj=?.s to #ms for if \?.oq then do
if !cms then '$CLEAR .WL='?.L _mm
if skp() then iterate
if !dos then call dsay,
esc || (?.L - 1) || ";0f"colorC.0 || _mm || scr0
end
call wr _mm
?.L= ?.L + 1
if ?.L>sd() then ?.L= 1
end /*jj*/
 
if \?.q then do return
if !cms then '$CLEAR .WL='?.L _mm
if !dos then call dsay,
esc || (?.L-1) || ";0f"colorC.0 || _mm || scr0
end
call wr _mm
?.L=?.L+1
if ?.L>sd() then ?.L=1
end /*jj*/
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
return
sayBrite: do jj=?.s to #ms for ?.o
if skp() then iterate
call wr _mm
if ?.q then iterate
 
if !cms then '$CLEAR .C=BRITE' _mm
/*──────────────────────────────────SAYBRITE subroutine─────────────────*/
else if !dos then call dsay colorC.0 || _mm || scr0
sayBrite: do jj=?.s to #ms for ?.o
if skp() then iterate end /*jj*/
call wr _mm
if ?.q then iterate
 
return
if !cms then '$CLEAR .C=BRITE' _mm
else if !dos then call dsay colorC.0 || _mm || scr0
end /*jj*/
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────SAYNLINE subroutine─────────────────*/
sayNline: do jj=?.s to #ms for ?.o
if skp() then iterate
 
if !dos then do
if ?.c=='' then call dsay _mm
else call dsay colorC.0 || _mm || scr0
call wr _mm
end
else call wit _mm
end /*jj*/
 
return
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────SAYHIGHLIGHT subroutine─────────────*/
sayHighlight:
do jj=?.s to #ms for ?.o
if skp() then iterate
 
if !cms then do
do jj=?.s to #ms for ?.o
if \?.q then '$CLEAR .C=HIGHL' _mm
if skp() then iterate
iterate
end
 
lenmm= length(_mm)
if !cms then do
__= verify(_mm, if \?.q thenahics, '$CLEAR .C=HIGHLM' _mm)
iterate
end
 
if __==0 then hc= lenmm + 1
lenmm=length(_mm)
else hc= __
__=verify(_mm,ahics,'M')
 
if __==0 then hc _xx=lenmm+ hue.1
else if hc>1 then _xx=__ _xx || left(_mm, hc - 1)
_xx=hue.1
if hc>1 then _xx=_xx || left(_mm, hc-1)
 
do jl=hc to lenmm
_=substr(_mm,jl,1)
 
do jcjl=minhichc to maxhiclenmm
if hhl.jc then if _==hics.jc then call hue 1 _= substr(_mm, colorC.jcjl, 1)
else if _==hice.jc then call hue -1
end /*jc*/
 
do jc=minhic to maxhic
if _=='' then _xx=_xx" "
if hhl.jc then if _==hics.jc then call hue 1, colorC.jc
__=verify(substr(_mm, jl+1), ahics, 'M')
else if _==hice.jc then call hue - 1
end /*jc*/
 
if ___==0'' then pl_xx=lenmm-jl+1 _xx" "
else pl= __= verify( substr(_mm, jl + 1), ahics, 'M')
 
if pl__==10 then iteratepl= lenmm - jl + 1
else pl= __
_xx=_xx || hue.hue# || substr(_mm, jl+1, pl-1)
jl=jl+pl-1
end /*jl*/
 
if pl==1 then iterate
if length(_xx)>sw() then if lenmm<=sw() then _xx = esc's'_xx || esc"u"
_xx= _xx || hue.hue# || substr(_mm, jl + 1, pl - 1)
call dsay _xx || scr0
jl= jl + pl - 1
call wr _mm
end /*jjjl*/
 
return
 
if length(_xx)>sw() then if lenmm<=sw() then _xx = esc's'_xx || esc"u"
/*──────────────────────────────────SKP subroutine──────────────────────*/
call dsay _xx || scr0
skp: if (onlyo\=='' & onlyo\==jj) |,
(onlys\=="" & onlys ==jj) call wr then return 1_mm
end /*jj*/
_mm = mm.jj
return 0
 
return
/*──────────────────────────────────TB subroutine───────────────────────*/
tb: tb=arg(1) /*test|verify Blank specification*/
if tb=='' then return left(arg(3), 1)
if length(tb)==2 then return valn("'"tb"'X", arg(2), 'X')
if length(tb)>1 then call er 30, tb "."arg(2)'=' 1
return tb
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────TELLIT subroutine───────────────────*/
skp: if (onlyo\=='' & onlyo\==jj) | (onlys\=="" & onlys ==jj) then return 1
tellIt: ___=arg(1) /*tell it to the display terminal*/
___ _mm= x1 || ___ || x2mm.jj
return 0
if boxing then ___=bx.8 || ?.eb || ___ || ?.eb || bx.4
call ms ___
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────VALN subroutine─────────────────────*/
tb: tb= arg(1) /*test|verify Blank specification*/
valn: procedure; parse arg x,n,k /*validate number (dec,bin,hex). */
_ if tb=='' then return left(xarg(3), 1)
if length(tb)==2 then return valn("'"tb"'X", arg(2), 'X')
v = "."n'='
if length(tb)>1 then call er 30, tb "."arg(2)'=' 1
if (_\=='"' & _\=="'") | ((right(x,2)\==_||k) & k\=='') then return x
return tb
arg ' ' -1 t
x = substr(x,2,length(x)-3)
_ = length(x)
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if t=='X' then do
tellIt: ___= arg(1) if \datatype(x, t) then/*tell callit erto 40,the xdisplay vterminal*/
___= returnx1 x2c(x)|| ___ || x2
if boxing then ___= bx.8 || ?.eb || ___ || ?.eb || endbx.4
 
if t=='B' call ms then do___
return
if \datatype(x, t) then call er 91, x v
return x2c(b2x(x))
end
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
if \datatype(x, 'W') then call er 53, x v
valn: procedure; parse arg x,n,k /*validate number (dec,bin,hex). */
return d2c(x)
_= left(x, 1)
v= "."n'='
if (_\=='"' & _\=="'") | ((right(x,2)\==_||k) & k\=='') then return x
arg ' ' -1 t
x= substr(x, 2, length(x) - 3)
_= length(x)
 
if t=='X' then do
/*──────────────────────────────────VEREB subroutine────────────────────*/
if \datatype(x, t) then call er 40, x v
VEReb: if arg(1)==0 then return /*character for Extra Blank(s). */
return x2c(x)
eb_ = x1 || copies(?.eb,tLL)x2
if boxing then eb_ = bx.8 || ?.eb || eb_ || ?.eb || bx.4 end
 
if t=='B' then do
if \datatype(x, t) then call er 91, x v
return x2c(b2x(x))
end
 
if \datatype(x, 'W') then call er 53, x v
return d2c(x)
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
VEReb: if arg(1)==0 then return /*character for Extra Blank(s). */
eb_ = x1 || copies(?.eb,tLL)x2
 
if boxing then eb_= bx.8 || ?.eb || eb_ || ?.eb || bx.4
 
do jeb=1 for arg(1)
call ms eb_
end /*jeb*/
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
VMcolor: if \!cms then return
parse arg c1,c2
 
if c1\=='' then call cp "SCREEN VMOUT" c1
if c2\=='' then "SET VSCREEN CMS" c2
return
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
wn: procedure expose ?. /*normalize, validate N in range.*/
arg z, L, H, d, t
_= ?.z
parse upper var _ f 2
m= pos(f, 'MH')\==0
 
if m | f=='*' then do
_= (word(d H L sw(), 1)) / word(1 2, m + 1)substr(_, 2)
if \datatype(_,"N") then interpret '_=' translate(_,"%",'/')
?.z= _
end
 
if datatype(_, "N") then do jeb?.z=1 _ for/ arg(1)
if \datatype(_, left(t"W", 1) ) then call er ms53, _ eb_'.'z"="
if L\=='' then if _<L | _>H then call er 81, L H _ "value for option end /*jeb*/."z'='
return _
 
/*──────────────────────────────────────────────────────────────────────────────────────*/
/*──────────────────────────────────VMCOLOR subroutine──────────────────*/
wr: parse arg wr /*write [argument 1] ───> disk. */
VMcolor: if \!cms then return
if ?.f=='' then return /*Nothing to write? Then skip it.*/
parse arg c1,c2
if highL & if c1ahics\=='' then callwr= translate(wr, , ahics) cp "SCREEN VMOUT"/*has c1highlighting?*/
if c2\=='' then "SET VSCREEN CMS" c2
return
 
if !cms | !tso then 'EXECIO 1 DISKW' ?.f "(FINIS STRING" wr
/*──────────────────────────────────WN subroutine───────────────────────*/
else call lineout ?.f, translate(wr, '10'x, "1a"x)
wn: procedure expose ?. /*normalize, validate N in range.*/
/*(above) Handle E-O-F character.*/
arg z, L, H, d, t
_ = ?.z
parse upper var _ f 2
m = pos(f,'MH')\==0
 
call lineout ?.f /*close the output file. */
if m | ,
return 0
f=='*' then do
_ = (word(d H L sw(),1)) / word(1 2,m+1)substr(_,2)
if \datatype(_,"N") then interpret '_='translate(_,"%",'/')
?.z = _
end
 
/*══════════════════════════════════════════════════════════════════════════════════════*/
if datatype(_,"N") then ?.z = _/1
!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
if \datatype(_,left(t"W",1)) then call er 53, _ '.'z"="
!cal: if symbol('!CALL')\=="VAR" then !call=; return !call
if L\=='' then if _<L|_>H then call er 81,L H _ "value for option ."z'='
!env: !env='ENVIRONMENT'; if !sys=="MSDOS" | !brexx | !r4 | !roo then !env='SYSTEM'; if !os2 then !env="OS2"!env; !ebcdic= 3=='f3'x; if !crx then !env='DOS'; return
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"; !crx= left(!sys, 6)=='DOSCRX'; call !rex; return
!var: call !fid; if !kexx then return space( dosenv(arg(1) ) ); return space( value(arg(1), , !env) )
$block: !call= '$BLOCK'; call "$BLOCK" arg(1); !call=; return result
$mkdir: !call= '$MKDIR'; call "$MKDIR" arg(1); !call=; return result
$scale: !call= '$SCALE'; call "$SCALE" arg(1); !call=; return result
cp: "EXECIO" '0'arg(2) "CP(STEM CP. STRING" arg(1); return rc
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
p: return word( arg(1), 1)
halt: call er .1
kw: parse arg kw; return kw c2x(?.kw)
lower: return translate( arg(1), @abc, @abcu)
noValue: !sigl= sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl)
proper: procedure; arg f 2; parse arg 2 r; return f || r
sd: if ?.scrdepth=='' then parse value scrsize() with ?.scrdepth ?.linesize .; return ?.scrdepth
sw: if ?.linesize=='' then ?.linesize= linesize(); return ?.linesize
syntax: !sigl= sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)
wit: call dsay arg(1); call wr arg(1); return</lang>
 
/*──────────────────────────────────WR subroutine───────────────────────*/
wr: parse arg wr /*write [argument 1] ───> disk. */
if ?.f=='' then return /*Nothing to write? Then skip it.*/
if highL & ahics\=='' then wr=translate(wr,, ahics) /*has highlighting?*/
 
if !cms | !tso then 'EXECIO 1 DISKW' ?.f "(FINIS STRING" wr
else call lineout ?.f, translate(wr, '10'x, "1a"x)
/*(above) Handle E-O-F character.*/
 
call lineout ?.f /*close the file. */
return
 
Programming note: &nbsp; this REXX program makes use of &nbsp; '''DELAY''' &nbsp; BIF which delays (sleeps) for a specified amount of seconds.
/*═════════════════════════════general 1-line subs══════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════*/
<br>Some REXXes don't have a &nbsp; '''DELAY''' &nbsp; BIF, &nbsp; so one is included here &nbsp; ──► &nbsp; [[DELAY.REX]].
!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))
.a: call wn 'A',-99,99,sd(); ?.ab=tb(?.ab,'AB'); return
$block: !call='$BLOCK'; call '$BLOCK' arg(1); !call=; return result
$mkdir: !call='$MKDIR'; call '$MKDIR' arg(1); !call=; return result
$scale: !call='$SCALE'; call '$SCALE' arg(1); !call=; return result
cp: 'EXECIO' '0'arg(2) "CP(STEM CP. STRING" arg(1); return rc
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
p: return word(arg(1),1)
halt: call er .1
kw: parse arg kw; return kw c2x(?.kw)
lower: return translate(arg(1),@abc,@abcu)
novalue:!sigl=sigl;call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl)
proper: procedure; arg f 2;parse arg 2 r; return f || r
sd: if ?.scrdepth=='' then parse value scrsize() with ?.scrdepth ?.linesize .;return ?.scrdepth
sw: if ?.Linesize=='' then ?.Linesize=linesize(); return ?.Linesize
syntax: !sigl=sigl;call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)
wit: call dsay arg(1); call wr arg(1); return</lang>
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/223790...223806"