Sudoku/REXX: Difference between revisions
Content added Content deleted
(fixed some HTML headers.) |
(used the current url's to point to other documentation instead of in-lining it here on this page.) |
||
Line 2: | Line 2: | ||
=={{header|REXX}}== |
=={{header|REXX}}== |
||
===REXX |
===REXX version 1=== |
||
This is the '''$SUDOKU.REX''' (REXX) program and is used to solve the Rosetta Code task of "sudoku". |
This is the '''$SUDOKU.REX''' (REXX) program and is used to solve the Rosetta Code task of "sudoku". |
||
<br><br>This REXX program was originally written to assist in sudoku puzzle solving (by giving strong hints), and not to solve the puzzle outright. |
|||
<br>The REXX program was written to give increasing better hints and also show the possibilities (of what is possible solution for any cell), |
|||
This REXX program was originally written to assist in sudoku puzzle solving (by giving strong hints), and not to solve the puzzle outright. |
|||
The REXX program was written to give increasing better hints and also show the possibilities (of what is possible solution for any cell), |
|||
<br>and to partially solve the puzzle using distinct strategies (separately or in combination). One option is to solve the puzzle. |
<br>and to partially solve the puzzle using distinct strategies (separately or in combination). One option is to solve the puzzle. |
||
<br><br>The help for the '''$SUDOKU''' REXX program is included here ──► [[Sudoku/REXX#REXX_Version_1_Help]]. |
|||
The help for the '''$SUDOKU''' REXX program is included here ──► [[Sudoku/REXX#REXX_Version_1_Help]]. |
|||
<br>The '''$ERR.REX''' REXX program is included here ──► [[Sudoku/REXX#REXX_Version_1_Errors]]. |
|||
The '''$SUDOKU.REX''' REXX program makes use of '''$ERR.REX''' REXX program which is used to display error messages (via '''$T.REX'''). |
|||
<br>The '''$T.REX''' REXX program is included here ──► [[Sudoku/REXX#REXX_Version_1_Messages]]. |
|||
The '''$ERR.REX''' REXX program is included here ──► [[Sudoku/REXX#REXX_Version_1_Errors]]. |
|||
<br>REXX programs not included are '''$H''' which shows '''help''' and other documentation. |
|||
The '''$SUDOKU.REX''' REXX program makes use of '''$T.REX''' REXX program which is used to display text messages. |
|||
The '''$T.REX''' REXX program is included here ──► [[Sudoku/REXX#REXX_Version_1_Messages]]. |
|||
Some older REXXes don't have a '''changestr''' BIF, so one is included here ───► [[CHANGESTR.REX]]. |
|||
REXX programs ''not'' included are '''$H''' which shows '''help''' and other documentation. |
|||
<lang rexx>/*REXX program displays, can give hints, and/or solve a sudoku puzzle. */ |
<lang rexx>/*REXX program displays, can give hints, and/or solve a sudoku puzzle. */ |
||
trace off |
trace off |
||
Line 821: | Line 831: | ||
tg: arg tg; if simple then tg=simple(tg); call $t gridindent || tg; return</lang> |
tg: arg tg; if simple then tg=simple(tg); call $t gridindent || tg; return</lang> |
||
===REXX Version 1 Output=== |
|||
This REXX program makes use of '''$ERR.REX''' REXX program |
|||
'''output''' when using the input of: |
|||
which is used to write (display) error messages to the terminal screen, with |
|||
<br> <tt> row 1 .5..7.89 row 2 9...3 row 3 1...89.4 row 4 ..9.....1 row 5 ..13.52 row 6 6.....5 row 7 .6.89...3 row 8 ....5...7 row 9 .98.2..5 pruneALL </tt> |
|||
supplemental text that identifies what program issued the error, and in some |
|||
cases, also identifies the failing REXX statement and some particulars about |
|||
the failure. |
|||
The '''$ERR.T.REX''' REXX program can be found here ───► [[$ERR.REX]]. |
|||
changestr $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$@@@@@@@@@@@@@@@@@@@@@@@@##############%%%%%%%%%%%%%%%%%%% |
|||
{{out|output| when using the input of: <br> |
|||
<tt> row 1 .5..7.89 row 2 9...3 row 3 1...89.4 row 4 ..9.....1 row 5 ..13.52 row 6 6.....5 row 7 .6.89...3 row 8 ....5...7 row 9 .98.2..5 pruneALL </tt>}} |
|||
<pre style="height:130ex"> |
<pre style="height:130ex"> |
||
$SUDOKU is showing the puzzle |
$SUDOKU is showing the puzzle |
||
Line 1,153: | Line 1,173: | ||
</pre> |
</pre> |
||
== REXX version 2 == |
|||
{{trans|PL/I]] |
|||
The '''$ERR.REX''' (REXX) program is used to issue various formatted error messages from other REXX programs. |
|||
<br><br>The '''$ERR.REX''' program makes use of the '''$T.REX''' program to issue the error messages in red (if available). |
|||
<br><br>The help for the '''$ERR''' REXX program is included here ──► [[$ERR.HEL]]. |
|||
<lang rexx>/*REXX*/ trace off /*turn off all REXX cmd err msgs.*/ |
|||
parse arg ! /*obtain the original arguments. */ |
|||
if !all(arg()) then exit /*if a request for doc, then exit*/ |
|||
if !cms then address '' /*handle ADDRESS for CMS. */ |
|||
signal on halt /*setup label for HALT condition.*/ |
|||
signal on noValue /* " " " NOVALUE " */ |
|||
signal on syntax /* " " " SYNTAX " */ |
|||
numeric digits 100 /*what the hell, support big 'uns*/ |
|||
/*══════list of external commands*/ |
|||
@ctty = 'CTTY' /*point to the CTTY command.*/ |
|||
@globalv = 'GLOBALV' /* " " " GLOBALV " */ |
|||
@finis = 'FINIS' /* " " " FINIS " */ |
|||
@subcom = 'SUBCOM' /* " " " SUBCOM " */ |
|||
@cpset = 'CP SET' /* " " " CP SET " */ |
|||
@conwait = 'CONWAIT' /* " " " CONWAIT " */ |
|||
@cpspool = 'CP SPOOL' /* " " " CP SPOOL " */ |
|||
@cmstype = 'SET CMSTYPE' /* " " " SET CMSTYPE " */ |
|||
if !cms | !dos then @ = '────────' /*use hyphens for dashes in msgs*/ |
|||
else @ = '--------' /* " minuses " " " " */ |
|||
parse var !! !! ' ..F=' ftops /*is $ERR to write errors to file*/ |
|||
if ftops\=='' then ftops='.F='ftops /*Yes, then add to FTOPS var. */ |
|||
etops=strip(ftops '.C=red .END=1') /*also, add to ETOPS variable. */ |
|||
g.1=space(!!) /*a version with no extra blanks.*/ |
|||
pblank='05'x /*use pseudoBlank as "true" blank*/ |
|||
do j=2 to 9 /*process some possible shortcuts*/ |
|||
k=j-1 /*point to the previous variable.*/ |
|||
parse var g.k a.k g.j /*get the "G" version (= "all"). */ |
|||
if a.k==',' then a.k= /*if omitted, then use a null. */ |
|||
g.k=translate(g.k,,pblank) /*translate to a true blank. */ |
|||
a.k=translate(a.k,,pblank) /* " " " " " */ |
|||
aU.k=a.k; upper aU.k /*get an uppercase version of a.k*/ |
|||
L.k=length(a.k) /*get the length of the a.k var.*/ |
|||
c.k=comma(a.k) /*add a comma (,) to the number. */ |
|||
w.k=length(c.k) /*get the length of commatized #.*/ |
|||
end /*j*/ |
|||
/* [↓] shortcut versions of a. */ |
|||
a2=a.2; a3=a.3; a4=a.4; a5=a.5; a6=a.6; a7=a.7; a8=a.8 |
|||
g3=g.3; g4=g.4; g5=g.5; g6=g.6; g7=g.7; g8=g.8 |
|||
aa5=a.5 |
|||
if isNum(aa5) then aa5=abs(aa5) /*if it's a number, use ABS value*/ |
|||
i=a.1 /*this is the error number. */ |
|||
errmsgto= |
|||
errmsgnt= |
|||
xedit=0 /*indicate no XEDIT (so far). */ |
|||
if !cms then do /*if CMS, then do some housework.*/ |
|||
@globalv 'SELECT' !fn 'GET ERRMSGTO ERRMSGNT' |
|||
@finis '* * *' |
|||
@cmstype 'RT' |
|||
@conwait |
|||
@cpspool 'CON TERM' |
|||
@cpset' IMSG ON' |
|||
@cpset' EMSG ON' |
|||
@subcom 'XEDIT' |
|||
xedit=\rc & \cmsflag('SUBSET') |
|||
ufid=a3 a4 a5 |
|||
end |
|||
if !dos then do /*if COS, then do some housework.*/ |
|||
if \!nt then @ctty 'con' /*Not Windows NT? Use CTTY cmd*/ |
|||
_=a4 |
|||
if _\=='' & right(_,1)\=="\" then _=_'\' |
|||
ufid=_ || a2"."a3 |
|||
end |
|||
i=space(translate(i,,'-'),0) /*remove all minus signs from str*/ |
|||
if i=='' then call erb 57 /*Is it null? Oops-say message.*/ |
|||
if i=0 then do /*if "error" is zero, show author*/ |
|||
_= /*start with a clean slate. */ |
|||
iL=length(i) /*use # of zeroes for more info. */ |
|||
if iL>1 then _=@'author'@"÷÷÷÷Gerard J. Schildberger" |
|||
if iL>2 then _=_ '÷÷phone (701)-242-8238' |
|||
if iL>3 then _=_ '÷÷E-mail gerardS@rrt.net' |
|||
if iL>5 then _=_ '÷÷9411 West Ridge Road,' |
|||
if iL>5 then _=_ '÷÷Hankinson, ND 58041' |
|||
atops=strip(ftops '.A=-2 .X=-2 .E=2 .C=yell .J=c .BOX= .KD=÷') |
|||
if _\=='' then call $t atops _ /*tell if more than 1 zero*/ |
|||
exit 0 /*exit with a return code of zero*/ |
|||
end |
|||
if i==14000 |, /*is this a message for a HALT ? */ |
|||
i=='14.1' then do /* ··· or in some cases, 14.1 */ |
|||
htops=strip(ftops '.X=-1 .C=red .J=c .BOX=') |
|||
call $t htops 'The REXX program' @ a2 @ "has been halted !" |
|||
exit 14000 /* ··· and indicate a HALT cond· */ |
|||
end |
|||
if \isInt(i) then call erb 53,i "error_code" /*Hmmm, an "internal" err*/ |
|||
oi=i /*keep the original value around.*/ |
|||
xedit= xedit & i>0 /*inside the XEDIT program? */ |
|||
i=abs(i) /*use the absolute value of I. */ |
|||
if i<1400 | i>1499 then call erb 99,oi /*check for a legal range of I. */ |
|||
k=i-1400 /*from now on, use a shorter I. */ |
|||
if xedit then address 'XEDIT' "SET MSGM ON LONG" /*allow XEDIT msgs.*/ |
|||
call sy /*write blank line.*/ |
|||
call sy "($$$"i") *error*:" /*write a hdr line.*/ |
|||
if k==0 then call sy "some commands can't or shouldn't be executed while in" g3 |
|||
if k==1 then call sy "the" g3 'was previously specified or specified more than once' |
|||
if k==2 then call sy "the" a4 "argument can't be" choose("negative",g5)":" a3 |
|||
if k==3 then call sy 'the (disk) filemode' a3 "can't have any read-only extensions" g4 |
|||
if k==4 then call sy 'the' a4 "filemode/address can't be" choose('RELEASEd',g5)":" a3 |
|||
if k==5 then do |
|||
call sy "illegal compator operator" @ a3 'specified,' |
|||
call sy "it must be one of: = \= < <= > >= \< \>" |
|||
end |
|||
if k==6 then call sy "no special characters are allowed in the" g4':' a3 |
|||
if k==7 then call sy "fixed-point underflow or overflow (result is too small or too large)" |
|||
if k==8 then call sy "illegal filemode" @ a3 @ g4 |
|||
if k==9 then call sy "a terminal screen (CRT) is required with the" @ a3 @ 'feature' |
|||
if k==10 then if a3=='' then call sy "missing fileid for" g4 |
|||
else call sy "illegal fileid" @ space(a3 a4 a5) @ g6 |
|||
if k==11 then call sy "comparand operand must be an = or \= when using *xxx* type comparisons" |
|||
if k==12 then call sy "not enough" choose('virtual storage',g4)", at least" a3 'are needed' |
|||
if k==13 then do |
|||
call sy "REXX syntax error" |
|||
if isInt(a.6) then call sy errortext(a.6) |
|||
call syline |
|||
end |
|||
if k==14 then call sy 'the' a5 "argument" a3 "can't be" choose('greater',a.7) "than" a6 a4 |
|||
if k==15 then do |
|||
if a3=='' then call sy "division by zero" |
|||
else do |
|||
call sy 'raising a negative number' @ a3 @ |
|||
call sy "to a negative or an odd fractional power" @ a4 @ |
|||
call fto g5 |
|||
end |
|||
end |
|||
if k==16 then do |
|||
call sy "illegal MDISK" g4 'address:' a3"," |
|||
call sy 'it must be exactly three hexadecimal characters (but not 000), or it may be' |
|||
call sy "preceeded by an asterisk (*) followed by three decimal characters" |
|||
end |
|||
if k==17 then do |
|||
call sy "undefined REXX variable referenced" a.6 |
|||
call syline |
|||
end |
|||
if k==18 then do |
|||
call sy "illegal MDISK address or filemode," |
|||
call sy "the 191 A MDISK address is reserved for the CMS user's private MDISK" |
|||
end |
|||
if k==19 then call sy 'numeric digits ('comma(a6)") isn't sufficient to" a4 a5 'to' a3 |
|||
if k==20 then call sy "the" a3 @ a4 'and' g5 @ "aren't alike" |
|||
if k==21 then call sy choose("increment",a3) 'must be preceeded by a plus (+) or a minus (-)' |
|||
if k==22 then do |
|||
_='combination of characters:' |
|||
if L.4==1 then _="character:" |
|||
call sy a3 'contains an invalid' _ g4 |
|||
end |
|||
if k==23 then call sy "the" a3 choose("option",a5) "requires the" a4 choose('option or feature',g6) |
|||
if k==24 then call sy "illegal" choose('volume',a4) "serial:" a3 ' (it must be six or less characters)' |
|||
if k==25 then do |
|||
call sy "you must be in the" a3 'mode/program to use the' |
|||
call sy "specified command (or it's" g4 "option)" |
|||
end |
|||
if k==26 then do |
|||
call sy "illegal MDISK" g4 'address:' a3"," |
|||
call sy 'it must be exactly three hexadecimal characters (but not 000)' |
|||
end |
|||
if k==27 then call sy choose('number',g4) "can't be negative or zero (must be positive):" a3 |
|||
if k==28 then call sy "duplicate" a3 'defined or specified:' g4 |
|||
if k==29 then call sy "illegal filemode:" a3', it must be one character' |
|||
if k==30 then do |
|||
call say30 |
|||
if a5==a6 | a6=='' | a6=="," then call sy "it must be" space(aa5 g8 _b) |
|||
else do |
|||
_to='to' |
|||
if a6==aa5+1 then _to="or" |
|||
call sy 'it must be from' aa5 _to a6 _b |
|||
end |
|||
end |
|||
if k==31 then call sy "no lines (or incorrect lines) were put in the program stack" g3 |
|||
if k==32 then call sy 'the command' a3 "exited, but it isn't supposed to exit or stop" |
|||
if k==33 then call sy 'the' a3 "MDISK isn't a CMS MDISK, it's in the wrong format" |
|||
if k==34 then call sy @ a3 a4 @ "can't be executed from the" a5 'MDISK' |
|||
if k==35 then do |
|||
call sy "no" choose('argument',a4) 'was specified after or' |
|||
call fto a3 g5 |
|||
end |
|||
if k==36 then call sy 'file' @ g3 @ "can't exist on the" a5 'MDISK' |
|||
if k==37 then do |
|||
y=a3 |
|||
_=pos(a3,'''"`{[(«') |
|||
if _\==0 then y=translate(word('single_quote double_quote grave_accent left_brace left_bracket left_parenthesis left_double_carrot',_),,"_") a3 |
|||
call sy 'unmatched' y g4 |
|||
end |
|||
if k==38 then call sy 'file' @ space(a3 a4 a5) @ choose("can't be located or is empty",g6) |
|||
if k==39 then call sy "the" a3 choose('argument',a8) 'must be' a4 a5 "the" a6 choose('argument',a7) |
|||
if k==40 then do |
|||
call sy 'argument' @ a3 @ "isn't a valid hexadecimal string/number" |
|||
call sy "(it contains a character other than 0123456789ABCDEFabcdef or a blank)" |
|||
call fto g4 |
|||
end |
|||
if k==41 then do |
|||
call sy "VM userid" @ g3 @ "doesn't exist or" |
|||
call sy 'is illegal (it may have an illegal character in it)' |
|||
end |
|||
if k==42 then call sy "the MDISK" a4 'for the user' a3 "doesn't exist" |
|||
if k==43 then call sy "illegal password for the" a3 a5 'MDISK was specified' |
|||
if k==44 then do |
|||
call sy "a CMS command is being used out of context, or" |
|||
call sy 'a command was renamed, or the FSTs have been altered' |
|||
_='DOS' |
|||
if !cms then _="CMS";call sy '(you may have to IPL' _")" |
|||
end |
|||
if k==45 then call sy 'VM userid' @ g3 @ "isn't logged on" |
|||
if k==46 then call sy "the file's" @ g4 "LRECL can't exceed" a3 |
|||
if k==47 then call sy a3 @ a4 @ "not found" g5 |
|||
if k==48 then do |
|||
_= |
|||
L=1 |
|||
if L.4==1 | right(aU.4,1)=='X' then _=" an" |
|||
if _=='' then L=0 |
|||
call sy @ a3 g5 @ 'contains'_ "invalid character"s(L)':' a4 |
|||
end |
|||
if k==49 then call sy "CP LINK error for MDISK" a4 'userid' a3 |
|||
if k==50 then do |
|||
call sy 'illegal/invalid' a3 "specified" @ a4 @ |
|||
call fto g5 |
|||
end |
|||
if k==51 then call sy choose("documentation",a5) 'for' a3 a4 "couldn't be located" |
|||
if k==52 then do |
|||
call sy "arguments aren't permitted" |
|||
call fto a4 |
|||
end |
|||
if k==53 then do |
|||
call sy 'argument' @ a3 @ "isn't numeric" g5 |
|||
call fto a4 |
|||
end |
|||
if k==54 then do |
|||
call sy "not enough" choose('arguments',a3) "were specified" g5 |
|||
call fto a4 |
|||
end |
|||
if k==55 then do |
|||
call sy "illegal argument" @ a3 @ g5 |
|||
call fto a4 |
|||
end |
|||
if k==56 then call sy "illegal number of" choose('arguments',a4) "were specified" g5 a3 |
|||
if k==57 then do |
|||
y=choose("arguments",a3) |
|||
z='was' |
|||
if translate(right(y,1))=="S" then z='were' |
|||
call sy "no" y z "specified" |
|||
end |
|||
if k==58 then call sy "only" g3 'argument's(a3) 'are accepted' |
|||
if k==59 then do |
|||
call sy "too many" choose('arguments',a3) "were specified" g5 |
|||
call fto a4 |
|||
end |
|||
if k==60 then call sy "argument#" a4 @ a3 @ 'must be an * or numeric' |
|||
if k==61 then call sy "conflicting arguments:" g3 |
|||
if k==62 then call sy choose('fileid1',a3) "and" choose('fileid2',a4) "can't be identical" g5 |
|||
if k==63 then do |
|||
call sy "no" 'argument was specified after or' |
|||
call fto g3 |
|||
end |
|||
if k==64 then call sy "up to" g3 'argument's(a3) 'are accepted' |
|||
if k==65 then call sy "bad argument" @ a3 @ "illegal use of" g4 |
|||
if k==66 then call sy "only" a3 'to' a4 "arguments are accepted" |
|||
if k==67 then call sy "unable to parse" a3 'from the results of:' g4 |
|||
if k==68 then do |
|||
call sy "return code" a3 'doing:' |
|||
call sy g4 |
|||
i=a3 |
|||
end |
|||
if k==69 then call sy 'user' @ a3 @ "can't be logged on while the command" @ a2 @ 'is running' |
|||
if k==70 then do |
|||
if a3==2 then call sy "the" @ a2 @ 'command must be executed under the' a4 "userid" |
|||
if a3==1 then call sy "the" @ a2 @ "command must be executed from the A MDISK" |
|||
call sy "illegal use of the" @ a2 @ "command, subrc="a3 |
|||
end |
|||
if k==71 then call sy "can't attach a" g3 |
|||
if k==72 then do |
|||
call sy 'argument' @ a3 @ "isn't alphabetic" g5 |
|||
call fto a4 |
|||
end |
|||
if k==73 then do |
|||
call sy "an attempt was made to execute an unauthorized or restricted command" |
|||
if g3\=='' then call sy g3 |
|||
end |
|||
if k==74 then call sy "the user" @ a3 @ 'must be in' a4 "mode" |
|||
if k==75 then call sy "no" choose('write',a4) "access to the" @ choose('A',space(left(a3),1)) @ "MDISK" |
|||
if k==76 then call sy a3 g5 "isn't known or supported:" a4 |
|||
if k==77 then call sy space('error' a3 "in writing to disk file" @ g4 @) |
|||
if k==78 then call sy choose("file",g6) @ a3 a4 a5 @ 'not found' |
|||
if k==79 then call sy "the time window for execution is" a3 'through' a4 |
|||
if k==80 then call sy @ a3 @ "isn't a known userid" |
|||
if k==81 then do |
|||
call sy 'argument' @ a5 space(@ g7) "is out of range" |
|||
_=max(w.3,w.4) |
|||
if L.3\==0 then call sy 'the lower limit is:' right(c.3,_) |
|||
if L.4\==0 then call sy 'the upper limit is:' right(c.4,_) |
|||
call fto a6 |
|||
end |
|||
if k==82 then call sy g4 @ a3 @ "can't be located" |
|||
if k==83 then call sy "the" @ g3 @ 'option is required' |
|||
if k==84 then call sy "file" @ g4 @ 'had a syntax error for' a3 |
|||
if k==85 then call sy "illegal combination of arguments:" g4 |
|||
if k==86 then do |
|||
call sy "the" choose(a3,a2) 'command is being invoked out of context' |
|||
if g4\=='' then call sy g4 |
|||
end |
|||
if k==87 then do |
|||
call sy 'argument' @ a3 @ "isn't a valid" choose('bit digit',a4) |
|||
call sy '(it contains more than one binary digit)' |
|||
call fto g5 |
|||
end |
|||
if k==88 then call sy g4 @ a3 @ "doesn't exist" |
|||
if k==89 then call sy 'the' a3 "command can't be found" |
|||
if k==90 then do |
|||
call sy 'evaluation of' a3 "contains a zero divisor and" |
|||
call sy 'the result is infinite' g4 |
|||
end |
|||
if k==91 then do |
|||
call sy 'argument' @ a3 @ "isn't a valid" choose('bit string',a4) |
|||
call sy '(it contains a non-binary character other than 0 or 1)' |
|||
call fto g5 |
|||
end |
|||
if k==92 then do |
|||
call sy choose('argument',a4) @ a3 @ "isn't a whole number (integer)" g7 |
|||
call fto a5 |
|||
end |
|||
if k==93 then call sy "file" @ g3 @ 'already exists' |
|||
if k==94 then call sy "the T-DISK requested can't be obtained" |
|||
if k==95 then call sy "not enough free storage can be obtained" |
|||
if k==96 then call sy "illegal file" @ g3 @ 'or it was incorrectly modified' |
|||
if k==97 then do |
|||
call sy "a command failed," |
|||
if a3\=='' then call sy "sub-command" @ g3 @',' |
|||
call sy "it's all or partially restricted to authorized users" |
|||
end |
|||
if k==98 then do |
|||
call sy "an attempt was made to execute the" @ a2 @ 'command while' |
|||
call sy "the user" @ userid() @ "was in disconnected mode" |
|||
end |
|||
if k==99 then call sy "illegal error number for the" !fn 'REXX EXEC' ":" g3 |
|||
if a2\=='' then call sy "for the" @ a2 @ 'command or function.' |
|||
call sy |
|||
if errmsgnt\=='' & errmsgto\=='' then call sy "A notification (via $M) of this error has been sent to" errmsgto |
|||
if !cms then @globalv 'SELECT' !fn "PURGE" |
|||
if \isInt(i) then call er 53,i |
|||
exit sign(oi)*i |
|||
/*═════════════════════════════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; if !crx then !env='DOS'; 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)) |
|||
$t: !call=']$T'; call "$T" arg(1); call=; return |
|||
choose: parse arg c1,c2; if c2=='' | c2=="," then return c1; return c2 |
|||
comma: procedure; parse arg _,c,p,t; c=pickBlank(c,","); o=p(p 3); p=abs(o); t=p(t 999999999); if \isInt(p) | \isInt(t) | p==0 | arg()>4 then return _; n=_'.9'; #=123456789; k=0; return comma_() |
|||
comma_: if o<0 then do; b=verify(_,' '); if b==0 then return _; e=length(_)-verify(reverse(_),' ')+1; end; else do; b=verify(n,#,"M"); e=verify(n,#'0',,verify(n,#"0.",'M'))-p-1; end; do j=e to b by -p while k<t; _=insert(c,_,j); k=k+1;end;return _ |
|||
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 |
|||
erb: call sy; if a2\=="" then call sy '('!fn "was invoked by the" @ a2 @ 'EXEC)'; call er arg(1),arg(2) |
|||
fto: parse arg fto ftox; ftoo='option'; if right(fto,2)=='()' then ftoo='function'; if fto\=='' then call sy "for the" ftoo @ space(fto ftox) @; return |
|||
halt: call er .1 |
|||
isInt: return datatype(arg(1),'W') |
|||
isNum: return datatype(arg(1),'N') |
|||
noValue: !sigl=sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) |
|||
opf: if right(arg(1),2)=='()' then return "function"; return 'option' |
|||
p: return word(arg(1),1) |
|||
pickBlank: procedure; parse arg x,y; arg xu; if xu=='BLANK' then return ' '; return p(x y) |
|||
s: if arg(1)==1 then return arg(3); return p(arg(2) 's') |
|||
say30: if a5==-1 then call sy 'illegal' a4":" a3; else call sy "illegal length of" a4":" a3; _t=p(a7 'character'); _b=_t || s(p(a6 aa5))" in length"; return |
|||
sy: sy=arg(1); if length(sy)<81 then do; call syit sy; return; end; sysy=; do forever while sy\==''; parse var sy _t sy; if length(sysy _t)<80 then do;sysy=sysy _t;iterate;end; call syitb;sysy=_t;end; if strip(sysy)\=='' then call syitb;return |
|||
syfunc: if left(a6,1)==']' then do; _sl=g8; call sy "invocation of an undefined REXX function/subroutine" substr(a6,2); end; return |
|||
syit: syit=arg(1); if xedit then address 'XEDIT' "EMSG" syit; else if a2=='$T' then say syit; else call $t etops syit; if errmsgto\=='' & syit\=='' then call '$M' errmsgto syit; return |
|||
syitb: if left(sysy,1)==' ' then sysy=substr(sysy,2); call syit sysy; return |
|||
syline: if a5\==0 then call sy 'on line' a5 "of" ufid; _sl=g7; call syfunc; if _sl\=='' then do; call sy; call sy "REXX sourceline is:"; call sy; call sy _sl; call sy; end; if !cms then do;'EXECSTAT' a2 a3;if rc==0 then "EXECDROP" a2 a3;end;return |
|||
syntax: !sigl=sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)</lang> |
|||
=== REXX Version 1 $T.REX === |
|||
This is the '''$T.REX''' (REXX) program which is used by other REXX programs to display error or informational message(s), |
|||
<br>some of the options follow): |
|||
* in color(s) (if supported) |
|||
* highlights (in color) parts (up to 8 unique parts) of the text (if supported) |
|||
* write text to a file |
|||
* breaks the text into multiple lines |
|||
* adds indentation |
|||
* justifies the text: left/right/center/justify (autofill) |
|||
* add blank lines before and/or after the displaying of text |
|||
* boxing (around) the text |
|||
* add spacing around the text inside the box |
|||
* only showing specific lines of the text messages |
|||
* suppressing specific lines of the text messages |
|||
* translation of certain characters in the text |
|||
* allowing other characters to be used for blanks |
|||
* repeating a text |
|||
* allows remarks in the text |
|||
* writes the message, waits for a confirmation to proceed |
|||
* delaying (waiting) after the text is displayed |
|||
* showing a scale and/or a ruler above/below the text message(s) |
|||
* supports hex/dec/bit strings |
|||
* changing the case of the text |
|||
* reverses the text |
|||
* inverts the bits for certain characters |
|||
* sounds alarm (beeps) after the text is displayed (if supported) |
|||
* displays the text in reverse video (if supported) |
|||
* displays the text in (big) block letters |
|||
* clear the screen after or before the displaying of text |
|||
* allows user-define option character, the default is '''.''' (period) |
|||
* and many other options |
|||
<br>The help for the '''$T''' REXX program is included here ──► [[$T.HEL]]. |
|||
<br><br>The '''$T''' REXX program makes use of '''$ERR''' REXX program which is used to display error messages (via '''$T'''). |
|||
<br>The '''$ERR''' REXX program is included here ──► [[$ERR.REX]]. |
|||
<br><br>The '''$T''' REXX program makes use of '''LINESIZE''' BIF which returns the terminals width (linesize). |
|||
<br>Some REXXes doen't have a '''LINESIZE''' BIF, so one is included here ──► [[LINESIZE.REX]]. |
|||
<br><br>The '''$T''' REXX program makes use of '''SCRSIZE''' BIF which returns the terminals width (linesize) and depth. |
|||
<br>Some REXXes doen't have a '''SCRSIZE''' BIF, so one is included here ──► [[SCRSIZE.REX]]. |
|||
<br><br>The '''$T''' REXX program makes use of '''DELAY''' 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 '''$T''' REXX program makes use of '''SOUND''' BIF which produces sounds via the PC speaker. |
|||
<br>Some REXXes doen't have a '''SOUND''' BIF, so one is included here ──► [[SOUND.REX]]. |
|||
<br><br>REXX programs not included are '''$H''' which shows '''help''' and other documentation. |
|||
<lang rexx>/*REXX*/ trace off /* There be many dragons below. */ |
|||
parse arg ! |
|||
if !all(0) then exit 0 /*help options and boilerplate.*/ |
|||
zz = !! /*save a copy of original args. */ |
|||
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', |
|||
'GRAY 1;37', |
|||
'BLUE 1;34', |
|||
'GREEN 1;32', |
|||
'TURQUOISE 1;36', |
|||
'RED 1;31', |
|||
'PINK 1;35', |
|||
'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 |
|||
#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 |
|||
hue# = 1 |
|||
minhic = 1 |
|||
?.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 #his |
|||
hh.jh=substr(word(his,jh),2) |
|||
end /*jh*/ |
|||
colorSupport=!pcrexx | !r4 | !roo /*colors are supported by these. */ |
|||
boxCH = '+-+|+-+|' /*define some boxing characters. */ |
|||
if !ebcdic then boxCH = 'acbfbcfabbbfabfa'x /*¼┐╝·╗┐½· <──single box.*/ |
|||
if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box.*/ |
|||
if colorSupport then do /*use pre-saved color values. */ |
|||
_=translate(!var('SCREEN'), ,";,") /*envVar.*/ |
|||
if \datatype(space(_,0), "W") then _='36 40' |
|||
scr0=esc || translate(0 _, ';', " ")'m' |
|||
colorC.0=scr0 |
|||
colorC.1=esc"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 _1=='H' then do |
|||
_=wordpos(_,his) |
|||
if _\==0 then do |
|||
?.hi._=dotv |
|||
iterate jz |
|||
end |
|||
end |
|||
end /*do 1*/ |
|||
if @=='' then @=lz || yy |
|||
else @=@ yy |
|||
lz= |
|||
end /*jz*/ |
|||
if left(@,1)==' ' then @=substr(@,2) /*handle this special case. */ |
|||
if ?.a\==0 then call .a |
|||
if ?.a\==0 then call .b |
|||
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 #his |
|||
_=?.hi._j |
|||
if _\=='' & \!regina then do |
|||
call colors _,"H"hh._j,_j |
|||
highL=1 |
|||
end |
|||
end /*_j*/ |
|||
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 ?.q\==0 then call wn 'Q',0,1 |
|||
if ?.r\==0 then call wn "R",0,99; ?.r=?.r+1 |
|||
if ?.ruler\==0 then call .ruler |
|||
if ?.s\==0 then call .s; ?.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 |
|||
if jt\==1 then if jt\==?.t then call VEReb ?.ts,?.tsb |
|||
do jj=1 for ## |
|||
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 |
|||
if ?.ruler<0 then call inches ?.ruler,0 |
|||
if ?.scale<0 then call inches ?.scale,1 |
|||
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) |
|||
if ?.b<0 then call call beeps ?.b |
|||
if ?.z\==0 then call .z |
|||
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. */ |
|||
return 0 |
|||
/*──────────────────────────────────.B subroutine───────────────────────*/ |
|||
.b: call wn 'B',-99,99,sd() /*B is for beeps (sounds). */ |
|||
if ?.bd\==.2 then do |
|||
_=translate(?.bd,,',') |
|||
__=_ |
|||
do while __\=='' |
|||
parse var __ ?.bd __ |
|||
call wn 'BD', .1, 9, ,"N" |
|||
end /*while*/ |
|||
?.bd=_ |
|||
end |
|||
if ?.bf\==800 then do |
|||
_=translate(?.bf,,',') |
|||
__=_ |
|||
do while __\=='' |
|||
parse var __ ?.bf __ |
|||
call wn 'BF', 1, 20000 |
|||
end /*while*/ |
|||
?.bf=_ |
|||
end |
|||
return |
|||
/*──────────────────────────────────.BLOCK subroutine───────────────────*/ |
|||
.block: call wn 'BLOCK',-12,12 |
|||
if ?.bs\==2 then call wn 'BS', -12, sw() |
|||
if ?.bc\=='' then ?.bc = tb(?.bc, "BC") |
|||
?.bb=tb(?.bb,'BB') |
|||
return |
|||
/*──────────────────────────────────.BOX subroutine─────────────────────*/ |
|||
.box: _=?.box; upper _ |
|||
if _=='*NONE*' then ?.box= |
|||
boxing= ?.box\=='' |
|||
if \boxing then return |
|||
if _=='SINGLELINE' then _=boxCH |
|||
if length(_)>8 then call er 30, '.BOX='_ "boxcharacters 1 8" |
|||
?.box=left(_,8,right(_,1)) |
|||
do _=1 for 8 |
|||
bx._=substr(?.box,_,1) |
|||
end /*_*/ |
|||
_=verify(@,' ')-1 |
|||
if _>0 then @=@ || copies(" ",_) |
|||
return |
|||
/*──────────────────────────────────.C subroutine───────────────────────*/ |
|||
.c: call colors ?.c,'C',0 |
|||
if !cms then do |
|||
call cp 'QUERY SCREEN',1 |
|||
parse var cp.1 "VMOUT" VMout |
|||
'QUERY VSCREEN CMS ALL (LIFO' |
|||
if rc==0 then pull "(" . . VScolor VSdisp . |
|||
if ?.c=='BRITE' then call VMcolor "DEFAULT NONE" |
|||
else call VMcolor color.0 ?.d, color.0 ?.d |
|||
end |
|||
if \colorSupport then ?.c= /*Most REXXes don't support color*/ |
|||
return |
|||
/*──────────────────────────────────.D subroutine───────────────────────*/ |
|||
.d: upper ?.d |
|||
_ = ?.d |
|||
if \(abbrev('BRITE',_,3) |, |
|||
abbrev("BRIGHT",_,3) |, |
|||
abbrev('HIGHLIGHT',_) |, |
|||
abbrev("NONE",_,3) |, |
|||
abbrev('REVVIDEO',_,3) |, |
|||
abbrev("UNDERLINE",_,3)) then call er 55, _ ".D=" |
|||
if !regina then ?.d= /*Regina can't handle DISP's. */ |
|||
else if left(_,1)=='H' then highL=1 |
|||
return |
|||
/*──────────────────────────────────.EF subroutine──────────────────────*/ |
|||
ef: if ?.f\=='' then call er 61, '.F= .EF=' /*conflicting options.*/ |
|||
?.f = ?.ef |
|||
return |
|||
/*──────────────────────────────────.F subroutine───────────────────────*/ |
|||
.f: _=?.f /*File where the text is written.*/ |
|||
if !cms then do |
|||
_=translate(_, , '/,') /*try to translate to CMS format.*/ |
|||
if words(_)>3 then call er 10, ?.f |
|||
?.f = _ word(subword(_,2) !fn,1) word(subword(_,3) 'A1',1) |
|||
end |
|||
__=lastpos("\",_) |
|||
if !dos & ?.ef=='' & __\==0 then call $mkdir left(_,__) |
|||
return |
|||
/*──────────────────────────────────.INV subroutine─────────────────────*/ |
|||
.inv: return x2c( b2x( translate( x2b( c2x( arg(1) ) ), 01, 10) ) ) |
|||
/*──────────────────────────────────.J subroutine───────────────────────*/ |
|||
.j: upper ?.j /*Justify (or not) the text. */ |
|||
if ?.j=='' then ?.j= 'N' /*Justify (or not) the text. */ |
|||
else ?.j= left(?.j,1) /*just use the first letter of .J*/ |
|||
if pos(?.j,"ACJLNR")==0 then call er 55, ?.j '.J=' |
|||
if ?.j=='A' then ?.j= substr(copies('LRC',30),random(1,90),1) |
|||
?.jb=tb(?.jb,'JB') /*while we're here, handle JB. */ |
|||
return |
|||
/*──────────────────────────────────.KS subroutine──────────────────────*/ |
|||
.ks: call wn 'KS', 0, 99, sw() |
|||
?.ksb = tb(?.ksb, 'KSB') /*blank lines between karate chop*/ |
|||
return |
|||
/*──────────────────────────────────.L subroutine───────────────────────*/ |
|||
.L: upper ?.L /*Line(s) for the text is shown. */ |
|||
if !cms then do |
|||
'$QWHAT DSC' |
|||
if rc==4 then ?.L=0 |
|||
end |
|||
if ?.L=='CMSG' then ?.L="*" |
|||
call wn 'L',-sd(),sd() |
|||
if ?.L<0 then ?.L=sd()-?.L |
|||
return |
|||
/*──────────────────────────────────.O subroutine───────────────────────*/ |
|||
.o: call wn 'O',-999,999,9999 |
|||
if ?.o<0 then do |
|||
onlyo=-?.o |
|||
?.o=9999 |
|||
end |
|||
return |
|||
/*──────────────────────────────────.P subroutine───────────────────────*/ |
|||
.p: if ?.q then return /*Post (writting) blank lines. */ |
|||
_=?.p |
|||
if _>98 |, |
|||
_<0 then do 1 |
|||
if !cms & _>9998 then call CPmore |
|||
!cls |
|||
if \!cms then leave /*1*/ |
|||
if _>9998 & more\=='' then call CP 'TERMINAL MORE' more |
|||
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold |
|||
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold |
|||
end /*1*/ |
|||
do abs(_) while _<99 |
|||
call wit bline |
|||
end /*abs*/ |
|||
do _=1 to -?.a |
|||
call wit bline |
|||
end /*_*/ |
|||
return |
|||
/*──────────────────────────────────.RULER subroutine───────────────────*/ |
|||
.ruler: call wn 'RULER', -sw(), sw() /*RULER draws a "ruler" line. */ |
|||
?.rulerb = tb(?.rulerb, 'RULERB') |
|||
return |
|||
/*──────────────────────────────────.S subroutine───────────────────────*/ |
|||
.s: call wn "S", -999, 999, 999 /*Skip (or suppress) line(s). */ |
|||
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 left(?.o,1)=="-" & left(?.s,1)=='-' then |
|||
call er 61,"O="?.o 'S='?.s "(both can't be negative)" |
|||
return |
|||
/*──────────────────────────────────.SCALE subroutine───────────────────*/ |
|||
.scale: call wn 'SCALE', -sw(), sw() /*SCALE draws a "scale" line. */ |
|||
?.scaleb = tb(?.scaleb, 'SCALEB') |
|||
?.scaled = tb(?.scaled, 'SCALED', ".") |
|||
?.scalep = tb(?.scalep, 'SCALEP', "+") |
|||
return |
|||
/*──────────────────────────────────.T subroutine───────────────────────*/ |
|||
.t: call wn 'T', 0, 99 /*Times the text is written. */ |
|||
if ?.ts\==0 then call wn 'TS', 0, 99 |
|||
?.tsb = tb(?.tsb, 'TSB') |
|||
return |
|||
/*──────────────────────────────────.U subroutine───────────────────────*/ |
|||
.u: upper ?.u /*handle uppercasing text parts. */ |
|||
?.u = left(?.u, 1) |
|||
if pos(?.u, " AFLUW")==0 then call er 55, ?.u '.U=' |
|||
if ?.u==' ' | ?.u=='A' then ?.u= |
|||
return |
|||
/*──────────────────────────────────.UT subroutine──────────────────────*/ |
|||
.ut: call wn 'T', 0, 99 /*Times the text is written. */ |
|||
?.ut=valn(?.ut, "UT") |
|||
if length(?.ut)//2==1 then |
|||
call er 30,?.ut 'translate-characters an-even-number-of' |
|||
return |
|||
/*──────────────────────────────────.V subroutine───────────────────────*/ |
|||
.v: upper ?.v /*video mode, Normal -or- Reverse*/ |
|||
?.v=left(?.v, 1) |
|||
if pos(?.v, " NR")==0 then call er 55, ?.v '.V=' |
|||
if ?.v==' ' | ?.v=='N' then ?.v= |
|||
return |
|||
/*──────────────────────────────────.W subroutine───────────────────────*/ |
|||
.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 subroutine───────────────────────*/ |
|||
.x: call wn 'X', -sw(), sw() |
|||
x2 = copies(?.xb, abs(?.x)) |
|||
if ?.x<0 then x1=x2 |
|||
LLx = length(x1 || x2) |
|||
return |
|||
/*──────────────────────────────────.XK subroutine──────────────────────*/ |
|||
.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 subroutine───────────────────────*/ |
|||
.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 subroutine────────────────────*/ |
|||
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 subroutine──────────────────*/ |
|||
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*/ |
|||
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 |
|||
ahue=word(hues,jj) |
|||
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 dark & left(cc,2)=='1;' then cc="0"substr(cc,2) |
|||
if !cms then do |
|||
if hue='GRAY' | hue=="BLACK" then hue='WHITE' |
|||
if hue="BROWN" then hue='YELLOW' |
|||
end |
|||
color.cc# = hue |
|||
colorC.cc# = esc || cc'm' |
|||
return |
|||
/*──────────────────────────────────CPMORE subroutine───────────────────*/ |
|||
cpMore: call cp 'QUERY TERM', 9 /*parse CP TERMINAL for MORE,HOLD*/ |
|||
__= |
|||
do jj=1 for cp.0 |
|||
__=__ cp.jj |
|||
end /*jj*/ |
|||
parse upper var __ 'MORE' more ',' 1 'HOLD' hold ',' |
|||
if _>9998 & more\=='' then call cp 'TERMINAL MORE 0 0' |
|||
if _>99999998 & hold\=='' then call cp 'TERMINAL HOLD OFF' |
|||
return |
|||
/*──────────────────────────────────DSAY subroutine─────────────────────*/ |
|||
dsay: if ?.q then return /*do SAY subroutine, write to scr*/ |
|||
dsay_ = strip(translate(arg(1), , '0'x), 'T') |
|||
say dsay_ |
|||
LLd = length(dsay_) /*length of last line displayed. */ |
|||
return |
|||
/*──────────────────────────────────HIGHLIGHT subroutine────────────────*/ |
|||
highLight: do _=1 for 7 |
|||
hhl._ = color._\=='' |
|||
hics._ = left(hh._,1) |
|||
hice._ = right(hh._,1) |
|||
if hhl._ then do |
|||
minhic= min(_,minhic); shics= shics || hics._ |
|||
maxhic= max(_,maxhic); ehics= ehics || hice._ |
|||
end |
|||
end /*_*/ |
|||
ahics=shics || ehics |
|||
return |
|||
/*──────────────────────────────────HUE subroutine──────────────────────*/ |
|||
hue: hue#=max(1, hue#+arg(1)) |
|||
__=arg(2) |
|||
if __\=='' then hue.hue#=__ |
|||
_= |
|||
return |
|||
/*──────────────────────────────────INCHES Subroutine───────────────────*/ |
|||
inches: /*handle RULER and SCALE stuff.*/ |
|||
_ = kw('RULERB') kw('SCALEB') kw('SCALEP') kw('SCALED') |
|||
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 |
|||
if \?.q then do |
|||
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 subroutine─────────────────*/ |
|||
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 |
|||
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 |
|||
/*──────────────────────────────────SAYHIGHLIGHT subroutine─────────────*/ |
|||
sayHighlight: |
|||
do jj=?.s to #ms for ?.o |
|||
if skp() then iterate |
|||
if !cms then do |
|||
if \?.q then '$CLEAR .C=HIGHL' _mm |
|||
iterate |
|||
end |
|||
lenmm=length(_mm) |
|||
__=verify(_mm,ahics,'M') |
|||
if __==0 then hc=lenmm+1 |
|||
else hc=__ |
|||
_xx=hue.1 |
|||
if hc>1 then _xx=_xx || left(_mm, hc-1) |
|||
do jl=hc to lenmm |
|||
_=substr(_mm,jl,1) |
|||
do jc=minhic to maxhic |
|||
if hhl.jc then if _==hics.jc then call hue 1, colorC.jc |
|||
else if _==hice.jc then call hue -1 |
|||
end /*jc*/ |
|||
if _=='' then _xx=_xx" " |
|||
__=verify(substr(_mm, jl+1), ahics, 'M') |
|||
if __==0 then pl=lenmm-jl+1 |
|||
else pl=__ |
|||
if pl==1 then iterate |
|||
_xx=_xx || hue.hue# || substr(_mm, jl+1, pl-1) |
|||
jl=jl+pl-1 |
|||
end /*jl*/ |
|||
if length(_xx)>sw() then if lenmm<=sw() then _xx = esc's'_xx || esc"u" |
|||
call dsay _xx || scr0 |
|||
call wr _mm |
|||
end /*jj*/ |
|||
return |
|||
/*──────────────────────────────────SKP subroutine──────────────────────*/ |
|||
skp: if (onlyo\=='' & onlyo\==jj) |, |
|||
(onlys\=="" & onlys ==jj) then return 1 |
|||
_mm = mm.jj |
|||
return 0 |
|||
/*──────────────────────────────────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───────────────────*/ |
|||
tellIt: ___=arg(1) /*tell it to the display terminal*/ |
|||
___ = x1 || ___ || x2 |
|||
if boxing then ___=bx.8 || ?.eb || ___ || ?.eb || bx.4 |
|||
call ms ___ |
|||
return |
|||
/*──────────────────────────────────VALN subroutine─────────────────────*/ |
|||
valn: procedure; parse arg x,n,k /*validate number (dec,bin,hex). */ |
|||
_ = 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 |
|||
if \datatype(x, t) then call er 40, x v |
|||
return x2c(x) |
|||
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 subroutine────────────────────*/ |
|||
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 subroutine──────────────────*/ |
|||
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 subroutine───────────────────────*/ |
|||
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 ?.z = _/1 |
|||
if \datatype(_,left(t"W",1)) then call er 53, _ '.'z"=" |
|||
if L\=='' then if _<L | _>H then call er 81,L H _ "value for option ."z'=' |
|||
return _ |
|||
/*──────────────────────────────────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 0 |
|||
/*═════════════════════════════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; if !crx then !env='DOS'; 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)) |
|||
.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> |
|||
=== REXX CHANGESTR.REX === |
|||
This version of the '''changestr''' BIF has more functionality than the standard BIF. |
|||
<lang rexx>/*REXX program emulates the CHANGESTR built-in function for older REXXes*/ |
|||
/*──── This version has more functionality: limit the number of changes.*/ |
|||
/*──── start of change occurrence#.*/ |
|||
/*──── start of change position. */ |
|||
/*╔══════════════════════════ CHANGESTR function ══════════════════════╗ |
|||
╔═╩════════════════════════════════════════════════════════════════════╩═╗ |
|||
║ The CHANGESTR function is used to replace some or all occurrences of an║ |
|||
║ (old) string in a haystack with a new string. The changed string is ║ |
|||
║ returned. If the haystack doesn't contain the old string, the ║ |
|||
║ original haystack is returned. If the old string is a null string, ║ |
|||
║ then the original string is prefixed with the new string. ║ |
|||
║ ║ |
|||
║ new string to be used►──────────┐ ┌─────◄limit of # changes (times).║ |
|||
║ original string (haystack)►──────┐ │ │ [default: ≈ one billion]║ |
|||
║ old string to be replaced►──┐ │ │ │ ┌────◄begin at this occurrence #║ |
|||
║ {O, H, and N can be null.} │ │ │ │ │ ┌──◄start position (default=1)║ |
|||
╚═╦════════════════════════════╗ │ │ │ │ │ │ ╔═════════════════════════╦═╝ |
|||
╚════════════════════════════╝ │ │ │ │ │ │ ╚═════════════════════════╝ |
|||
↓ ↓ ↓ ↓ ↓ ↓ */ |
|||
changestr: parse arg o,h,n,t,b,p,$ f /*T,B,P are optional.*/ |
|||
t=word(t 999999999 , 1) /*maybe use the default? */ |
|||
b=word(b 1 , 1) /* " " " " */ |
|||
p=word(p 1 , 1) /* " " " " */ |
|||
if arg() < 3 then signal syntax /*not enough arguments. */ |
|||
if arg() > 6 then signal syntax /*too many arguments. */ |
|||
if \datatype(t,'W') then signal syntax /*4th arg not an integer. */ |
|||
if \datatype(b,'W') then signal syntax /*5th " " " " */ |
|||
if \datatype(p,'W') then signal syntax /*5th arg " " " */ |
|||
if t<0 then signal syntax /*4th arg not non-negative*/ |
|||
if b<1 then signal syntax /*5th arg not positive. */ |
|||
if p<1 then signal syntax /*6th " " " */ |
|||
L=length(o) /*length of OLD string. */ |
|||
if L==0 & t\=0 then return n || h /*changing a null char? */ |
|||
if p\=1 then do /*if P ¬= 1, adjust F & H.*/ |
|||
f=left(h, min(p-1, length(h))) /*keep first part intact. */ |
|||
h=substr(h,p) /*only use this part of H.*/ |
|||
end /*now, proceed as usual. */ |
|||
#=0 /*# of changed occurrences*/ |
|||
do j=1 while # < t /*keep changing, T times. */ |
|||
parse var h y (o) _ +(L) h /*parse the haystack ··· */ |
|||
if _=='' then return f || $ || y /*no more left, return. */ |
|||
$=$ || y /*append the residual txt.*/ |
|||
if j<b then $=$ || o /*append OLD if too soon. */ |
|||
else do /*met the occurrence test.*/ |
|||
$=$ || n /*append the NEW string.*/ |
|||
#=#+1 /*bump occurrence number.*/ |
|||
end |
|||
end /*j*/ /*Note: most REXX ··· */ |
|||
/* CHANGESTR BIFs only ···*/ |
|||
return f || $ || h /* support three options. */</lang> |
|||
===REXX: Version 2 === |
|||
'''Translation of''' [[Sudoku#PL/I]] |
|||
<lang rexx> Parse Arg g.0fid |
<lang rexx> Parse Arg g.0fid |
||
Select |
Select |
||
Line 2,752: | Line 1,413: | ||
9 7 6 3 5 8 1 2 4</pre> |
9 7 6 3 5 8 1 2 4</pre> |
||
==REXX |
== REXX version 3 == |
||
This is version 1 (thanks) cut to the essentials, restructured, and modified |
This is version 1 (thanks) cut to the essentials, restructured, and modified |
||
<lang rexx>/* REXX --------------------------------------------------------------- |
<lang rexx>/* REXX --------------------------------------------------------------- |
||
Line 3,757: | Line 2,418: | ||
End |
End |
||
Exit 12</lang> |
Exit 12</lang> |
||
===REXX Version 2 Output=== |
|||
{{out}} |
{{out}} |
||
<pre> |
|||
<pre>process file sdk087.in |
|||
process file sdk087.in |
|||
Input from sdk087.in |
Input from sdk087.in |
||
Debug output to 0 |
Debug output to 0 |
||
Line 3,769: | Line 2,432: | ||
. . . . 7 1 5 . . |
. . . . 7 1 5 . . |
||
. . 2 4 . 6 . 1 8 |
. . 2 4 . 6 . 1 8 |
||
|
|||
. . . . . 9 . 4 6 |
. . . . . 9 . 4 6 |
||
. 9 . 6 1 8 . 3 . |
. 9 . 6 1 8 . 3 . |
||
6 1 . 7 . . . . 9 |
6 1 . 7 . . . . 9 |
||
|
|||
4 3 . 8 . 7 6 . . |
4 3 . 8 . 7 6 . . |
||
. . 8 1 4 . . . . |
. . 8 1 4 . . . . |
||
. . 9 . . . . . . |
. . 9 . . . . . . |
||
|
|||
solved |
solved |
||
7 4 1 9 8 5 3 6 2 |
7 4 1 9 8 5 3 6 2 |
||
3 8 6 2 7 1 5 9 4 |
3 8 6 2 7 1 5 9 4 |
||
9 5 2 4 3 6 7 1 8 |
9 5 2 4 3 6 7 1 8 |
||
|
|||
8 2 7 3 5 9 1 4 6 |
8 2 7 3 5 9 1 4 6 |
||
5 9 4 6 1 8 2 3 7 |
5 9 4 6 1 8 2 3 7 |
||
6 1 3 7 2 4 8 5 9 |
6 1 3 7 2 4 8 5 9 |
||
|
|||
4 3 5 8 9 7 6 2 1 |
4 3 5 8 9 7 6 2 1 |
||
2 6 8 1 4 3 9 7 5 |
2 6 8 1 4 3 9 7 5 |
||
1 7 9 5 6 2 4 8 3 |
1 7 9 5 6 2 4 8 3 |
||
</pre> |