Rosetta Code

Sudoku/REXX: Difference between revisions

Page Discussion

Sudoku/REXX (view source)

Revision as of 00:02, 4 October 2014

2,247 bytes removed ,  9 years ago
→‎REXX Version 1 Messages: Copy error.
(Add collection)
Line 1,538:
 
=== REXX Version 1 Messages ===
This is the   '''$SUDOKUT.REX'''   (REXX) program andwhich is used toby solveother theREXX Rosettaprograms Codeto taskdisplay oferror "sudoku".or informational message(s),
<br>some of the options follow):
<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.
* in color(s) &nbsp; &nbsp; (if supported)
<br>The REXX program was written to give increasing better hints and also show the possibilities (of what is possible solution for any cell),
* highlights (in color) parts (up to 8 unique parts) of the text &nbsp; &nbsp; (if supported)
<br>and to partially solve the puzzle using distinct strategies (separately or in combination). &nbsp; One option is to solve the puzzle.
* write text to a file
<br><br>The help for the &nbsp; '''$SUDOKU''' &nbsp; REXX program is included here ──► [[$SUDOKU.HEL]].
* breaks the text into multiple lines
<br>The &nbsp; '''$SUDOKU.REX''' &nbsp; REXX program makes use of &nbsp; '''$ERR.REX''' &nbsp; REXX program which is used to display error messages (via &nbsp; '''$T.REX''').
* adds indentation
<br>The &nbsp; '''$ERR.REX''' &nbsp; REXX program is included here ──► [[$ERR.REX]].
* justifies the text: left/right/center/justify &nbsp; (autofill)
<br>The &nbsp; '''$SUDOKU.REX''' &nbsp; REXX program makes use of &nbsp; '''$T.REX''' &nbsp; REXX program which is used to display text messages.
* add blank lines before and/or after the displaying of text
<br>The &nbsp; '''$T.REX''' &nbsp; REXX program is included here ──► [[$T.REX]].
* boxing (around) the text
<br>Some older REXXes don't have a &nbsp; '''changestr''' &nbsp; BIF, so one is included here ──► [[CHANGESTR.REX]].
* add spacing around the text inside the box
<br>REXX programs not included are &nbsp; '''$H''' &nbsp; which shows '''help''' and other documentation.
* only showing specific lines of the text messages
<lang rexx>/*REXX program displays, can give hints, and/or solve a sudoku puzzle. */
* suppressing specific lines of the text messages
trace off
* 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 &nbsp; &nbsp; (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 &nbsp; '''.''' &nbsp; &nbsp; (period)
* 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 &nbsp; '''$ERR''' &nbsp; REXX program is included here ──► [[$ERR.REX]].
<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''' &nbsp; BIF which returns the terminals width (linesize) and depth.
<br>Some REXXes doen't have a &nbsp; '''SCRSIZE''' &nbsp; BIF, so one is included here ──► [[SCRSIZE.HEL]].
<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 &nbsp; '''DELAY''' &nbsp; BIF, so one is included here ──► [[DELAY.REX]].
<br><br>The &nbsp; '''$T''' &nbsp; REXX program makes use of &nbsp; '''SOUND''' &nbsp; BIF which produces sounds via the PC speaker.
<br>Some REXXes doen't have a &nbsp; '''SOUND''' &nbsp; BIF, so one is included here ──► [[SOUND.REX]].
<br><br>REXX programs not included are &nbsp; '''$H''' &nbsp; which shows '''help''' and other documentation.
<lang rexx>/*REXX*/ trace off /* There be many dragons below. */
parse arg !
if !all(arg()0) then exit 0 /*help options and boilerplate.*/
if !cms then address ''
signal on halt
signal on noValue
signal on syntax
 
opszz = !! /*save a copy of original args. /*remove extraneous blanks.*/
if !cms then address ''
numeric digits 20
signal on halt /*be able to handle a HALT. */
combos=1
@.='signal 'on noValue /*catch REXX vars with noValue. /*initialize grid to blanks*/
!.=signal on syntax /*catch REXX syntax errors. /*nullify valid empty# list*/
numeric digits 300 /*be able to handle some big 'uns*/
@abc='abcdefghijklmnopqrstuvwxyz'
@abcU=@abc
upper @abcU
colors=!cms | !pcrexx | !r4 | !roo /*Are colors supported ? */
clear=1 /*option: clear the screen.*/
highLight=0 /*option: highlight singles*/
pruneall=0 /*option: prune all. */
prunemats=0 /*option: prune matches. */
prunesing=0 /*option: prune singles. */
pruneexcl=0 /*option: prune exclusives.*/
pruneline=0 /*option: prune lines. */
pruneonly=0 /*option: prune onlys. */
simple=0 /*option: show simple boxes*/
showoneline=0 /*option: show grid as1line*/
showgrid=1 /*option: show the grid. */
showinfo=1 /*option: show informatiion*/
showposs=0 /*option: show possible val*/
showcomb=0 /*option: show combinations*/
showrow= /*option: SHOWPOSS for rowN*/
showcol= /*option: SHOWPOSS for colN*/
showbox= /*option: SHOWPOSS for boxN*/
showcell= /*option: SHOWPOSS cellRC */
short=0
solve=0 /*option: solve the puzzle.*/
sod=lower(translate(!fn,,'$')) /*name of the puzzle. */
tellinvalid=1 /*tell err msg if invalid X*/
tops= /*option: used for $T opts.*/
 
gridindentshues=3space( 'BLACK 0;30', /*define some colors for DOS. /*# spaces grid is indented*/
gridindent=left('',gridindents) 'BROWN /*spaces indented for grid.*/0;33',
'DEFAULT 1;37',
gridwidth=7 /*grid cell interior width.*/
gridbar='b3'x 'GRAY /*bar for the grid (cells).*/1;37',
gridlt='da'x 'BLUE /*grid cell left top. */1;34',
gridrt='bf'x 'GREEN /*grid cell right top. */1;32',
'TURQUOISE 1;36',
gridlb='c0'x /*grid cell left bottom. */
gridrb='d9'x 'RED /*grid cell right bottom. */1;31',
gridline='c4'x 'PINK /*grid cell line (hyphen). */1;35',
gridlin=copies(gridline,gridwidth) /*grid cell'YELLOW total line. */1;33',
gridemp=left('',gridwidth) 'WHITE /*grid cell empty (spaces).*/1;37',
griddj='c2'x 'BRITE 1;37') /*colors for DOS via /*grid cellANSI.SYS down junction.*/
griduj='c1'x /*grid cell up junction.*/
gridlj='c3'x /*grid cell left junction.*/
gridrj='b4'x /*grid cell right junction.*/
gridcross='c5'x /*grid cell cross junction.*/
 
_= do while ops\=='' /*parse(below) set some anyvars and──> allNULL options*/
parse var ops_ _1?. 2@ 1 _color. colorC. 1ahics ehics hold lz more _oonlyo opsonlys,
scr0 shics VMout VScolor VSdisp x1 x2
upper _
 
@abc = 'abcdefghijklmnopqrstuvwxyz'
select
@abcU = @abc; upper @abcU
when _==',' then nop
when _1=='.' & pos("=",_)\==0 then tops=tops _o
 
#ms = 0
when abb('PUZzle') then /*do PUZZ (whole) placement*/
?.a = do0
?.b = puzz=na()0
?.block = 0
if length(puzz)>81 then call er 30,puzz 'PUZZLE 1───►81'
?.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
do j=1 for length(puzz)
hue# = 1
q=substr(puzz,j,1)
minhic = 1
if q=='.' then iterate
?.t = 1
call vern q,'PUZZLE_digit'
c=j//9
if c==0 then c=9
r=(j-1)%9 + 1
@.r.c=q
end /*j*/
end
 
?.bd = .2
when _=='CELL' then /*do CELL (grid) placement.*/
?.bf = do800
?.bs = rc=nai()2
?.o = 9999
if length(rc)\==2 then call er 30,y 'CELL'rc 2
?.rulerb = ' '
y=na()
?.scaleb = ' '
if length(y)>1 then call er 30,y 'CELL'rc 1
?.scaled = '.'
r=left(rc,1)
?.scalep = '+'
c=right(rc,1)
?.use = '.'
call vern r,'CELLrow'
esc = call vern c,'CELLcolumn1b'x"["
call vern y,'CELLdigit'
@.r.c=y
end
 
his='H() H{} H[] H<> H≤≥ H«» H/\'
when abb('COLumn') then /*do ROW (grid) placement. */
#his=words(his)
do
do jh=1 for #his
n=nai()
hh.jh=substr(word(his,jh),2)
y=na()
end /*jh*/
call vern n,'column'
ly=length(y)
if ly>9 then call er 30,y 'column'n '1───>9'
 
colorSupport=!pcrexx | !r4 | !roo /*colors are supported by these. */
do j=1 for ly
x=substr(y,j,1)
if x=='' | x=="_" | x=='*' | x=="." then iterate
if \isInt(x) then call er 92,x 'cell_for_column'n
@.j.n=x
end /*j*/
end
 
when abb('ROW') then boxCH = '+-+|+-+|' /*dodefine ROWsome (grid)boxing placementcharacters. */
if !ebcdic then boxCH = 'acbfbcfabbbfabfa'x /*¼┐╝·╗┐½· <──single box.*/
do
if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box.*/
n=nai()
y=na()
call vern n,'row'
ly=length(y)
if ly>9 then call er 30,y 'row'n '1───>9'
 
if colorSupport then do /*use pre-saved color values. do j=1 for ly*/
x_=substrtranslate(y!var('SCREEN'),j ,1";,") /*envVar.*/
if x==''\datatype(space(_,0), | x=="_W") | x=then _='*36 40' | x=="." then iterate
scr0=esc || if \isInttranslate(x)0 _, then';', call er 92,x" ")'cell_for_row_m'n
@colorC.n.j0=xscr0
end /*j*/colorC.1=esc"1;33m"
end
 
do jz=1 while zz\==''
when abbn('CLearscreen') then clear=no()
if ?.end==1 | pos('=',zz)==0 | pos(" "?.use,' 'zz)==0 then do
when abbn('HIGHLightsingles') then highLight=no()
@=@ zz
when abbn('PRUNEALL') then pruneall=no()
leave
when abbn('PRUNEONLYs') then pruneonly=no()
end
when abbn('PRUNEEXclusives') then pruneexcl=no()
if when abbnleft(zz,1)=='PRUNELINEs ') then prunelinelz=no()lz" "
parse var zz yy1 2 yy2 3 1 yy ' ' zz
when abbn('PRUNEMATches') then prunemats=no()
when abbn('PRUNESINGles') then prunesing=no()
when abbn('SIMPle') then simple=no()
when abb('SHOWBOXes')|,
abb('SHOWBOXs') then showbox=nai()
when abb('SHOWCELLs') then showcell=translate(na(),,',')
when abb('SHOWCOLs') then showcol=nai()
when abbn('SHOWCOMBinations') then showcomb=no()
when abbn('SHOWGrid') then showgrid=no()
when abbn('SHOWINFOrmation') then showinfo=no()
when abbn('SHOWONELINE') then showoneline=no()
when abbn('SHOWPOSSibles') then showposs=no()
when abb('SHOWROWs') then showrow=nai()
when abbn('SHortgrid') then short=no()
when abbn('SOLvepuzzle') then solve=no()
 
if yy1==?.use & pos('=',yy)\==0 & datatype(yy2,"U") then
otherwise call er 55,_o
end do /*select*/1
parse var yy 2 _ "=" dotv 2 _1 3
end /*while ops¬==''*/
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
if solve then pruneall=1 /*if solving, use PRUNEALL.*/
_=wordpos(_,his)
if _\==0 then do
?.hi._=dotv
iterate jz
end
end
end /*do 1*/
 
if @=='' then @=lz || yy
if pruneall then do /*if pruneAll, set ON other*/
else @=@ pruneexcl=1yy
lz=
pruneonly=1
end pruneline=1/*jz*/
prunemats=1
prunesing=1
end
 
if left(@,1)==' ' then @=substr(@,2) /*handle this special case. */
aprune = , /*is there a PRUNExxx on ? */
pruneexcl |,
pruneonly |,
pruneline |,
prunemats |,
prunesing
 
if ?.a\==0 then call .a
if highLight then do /*HIGHLIGHTSINGLES opt on? */
if ?.a\==0 then call hLl='-'.b
if ?.block\==0 then call .block
hLr='-'
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
 
if colors then do _j=1 for #his
hLl_='('?.hi._j
if _\=='' & \!regina then hLr=')'do
tops='.H=yell' tops call colors _,"H"hh._j,_j
end highL=1
end
end /*_j*/
 
if ?.i\==0 then do
tops=space(tops)
call wn 'I',0,sw()
box.=
?.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)
do j=1 for 9 /*build the box bounds. */
rr=(((j*3)%10)+1)*3-2 else /*compute row lower bound. */tLL=LL
cc=(((j-1)//3)+1)*3-2 /*compute col lower bound. */
boxr.j=rr
boxc.j=cc
 
bline=strip(indent || x1 || copies(?.ab, tLL+4*boxing)x2, 'T')
do r=rr to rr+2 /*build boxes with cell #s.*/
do c=cc to cc+2
rc=r || c
box.j=box.j rc
box.rc=j
end /*c*/
end /*r*/
 
if boxing then call ms bx.1 || copies(bx.2, LLx+tLL+2)bx.3
box.j=strip(box.j)
caLL VEReb ?.e,?.eb
end /*j*/
 
do jt=1 for ?.t
rowlb.=10 /*row R, low box number=b.*/
if jt\==1 then if jt\==?.t then call VEReb ?.ts,?.tsb
collb.=10 /*col R, low box number=b.*/
boxlr.=10 /*box B, low row number=r.*/
boxlc.=10 /*box B, low col number=c.*/
 
do do rjj=1 for 9##
doif cjj\==1 for 9 then call VEReb ?.ks,?.ksb
rc=r || c
b=box.rc /*what box is this R,C in ?*/
rowlb.r=min(rowlb.r,b) /*find min box # for row R.*/
collb.c=min(collb.c,b) /*find min box # for col C.*/
boxlr.b=min(boxlr.b,r) /*find min row # for box B.*/
boxlc.b=min(boxlc.b,c) /*find min col # for box B.*/
end /*c*/
end /*r*/
 
if boxing then _=left(tx.jj,tLL)
do j=1 to 9 /*for each box, row, col...*/
rowhb.j=rowlb.j+2 else /*compute row's high box #_=tx.*/jj
colhb.j=collb.j+6 /*compute col's high box #.*/
boxhr.j=boxlr.j+2 /*compute box's high row #.*/
boxhc.j=boxlc.j+6 /*compute box's high col #.*/
end /*j*/
 
if ?.v=='R' then _=reverse(_)
if showgrid then call showgrid 'the puzzle' /*show the grid to screen ?*/
if \validall() then exit /*validate specified digits*/
tellinvalid=0 /*don't tell err messages. */
!.= /*nullify valid empty# list*/
call buildposs /*build possible values. */
if showposs then call showgrid 'puzzle possibles' /*show 1st possibles?*/
if \validate(1) then exit /*validate the puzzle. */
 
if ?.u\=='' then select
if showoneline then do /*show grid as line line ? */
_= when ?.u=='A' then /*start with a clean slate.*/nop
when ?.u=='U' then do r=1 forupper 9_
when ?.u=='L' then do c_=1 for 9lower(_)
when ?.u=='F' then _=proper(_ || @.r.c /*build the string ... */)
when ?.u=='W' then end /*c*/do
end /*r*/ __=
do jw=1 for words(_)
__=__ proper(word(_,jw))
end /*jw*/
 
_=translate(strip(_,'T'),".",' '__)
if showinfo then call $T 'one-line grid:' end
call $T _end /*select*/
end
 
if ?.block==0 then call tellIt _
if aprune |,
else call blocker
showposs then do
end /*jj*/
call pruneposs /*go build poss, then prune*/
end /*jt*/
if showposs then call showgrid 'possibles' /*show grid.*/
if \validate(1) then exit /*validate the puzzle. */
end
 
call VEReb ?.e,?.eb
if combos==1 then call $t sod 'puzzle solved.'
if boxing then call ms bx.7 || copies(bx.6,LLx+tLL+2)bx.5
else if showcomb then call $t 'combinations='comma(combos)
call beeps ?.b
exit /*stick a fork in it, we're done.*/
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.*/
/*─────────────────────────────vern subroutine──────────────────────────*/
vern: parse argwhen v,whighL /*verify a digit for an opt*/ then call sayHighlight
if v when \highL & (?.c=='BRITE' | ?.c=="BRIGHT") then call er 35,v wsayBright
when ?.L\==0 then call sayAline
if \isInt(v) then call er 92,v w
otherwise call sayNline
if v<1 | v>9 then call er 81,1 9 v w
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───────────────────*/
/*─────────────────────────────buildposs subroutine─────────────────────*/
.block: call wn 'BLOCK',-12,12
buildposs: !.= /*nullify possibilities. */
if ?.bs\==2 then call wn 'BS', -12, sw()
combos=1
if ?.bc\=='' then ?.bc = tb(?.bc, "BC")
?.bb=tb(?.bb,'BB')
return
 
/*──────────────────────────────────.BOX subroutine─────────────────────*/
do rp=1 for 9 /*build table of valid #s. */
.box: _=?.box; upper _
do cp=1 for 9 /*step through each column.*/
if _=='*NONE*' then ?.box=
if @.rp.cp\==' ' then iterate /*not blank? Keep looking.*/
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───────────────────────*/
do jd=1 for 9 /*try each digit. */
.c: call colors ?.c,'C',0
@.rp.cp=jd
if validx(rp,cp) then !.rp.cp=!.rp.cp || jd
end /*jd*/
 
if !cms then do
combos=combos*length(!.rp.cp) /*calculate # combinations.*/
call cp 'QUERY SCREEN',1
@.rp.cp=' ' /*restore the point (blank)*/
end /* parse var cp*/.1 "VMOUT" VMout
end /*rp*/ '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───────────────────────*/
/*─────────────────────────────showgrid subroutine──────────────────────*/
.d: upper ?.d
showgrid: parse arg title
_ = ?.d
if clear then !cls /*clear the screen ? */
if title\=='' & showinfo then call $t !fn 'is showing' title
gtail=copies3(gridlb || gridlin || copies2(griduj || gridlin) || gridrb)
ghead=copies3(gridlt || gridlin || copies2(griddj || gridlin) || gridrt)
call tg ghead
gemp=copies3(copies3(gridbar || gridemp)gridbar)
grid=copies3(gridlj || gridlin || copies2(gridcross || gridlin)gridrj)
anyshow= \ ((showcell || showcol || showrow || showbox)\=='')
 
if \(abbrev('BRITE',_,3) |,
do jr=1 for 9
abbrev("BRIGHT",_,3) |,
if \short then call tg gemp
abbrev('HIGHLIGHT',_) |,
gnum=
abbrev("NONE",_,3) |,
abbrev('REVVIDEO',_,3) |,
abbrev("UNDERLINE",_,3)) then call er 55, _ ".D="
 
if !regina then ?.d= /*Regina can't handle DISP's. */
do jc=1 for 9
else if left(_,1)=='H' then highL=1
_=@.jr.jc
return
if _\==' ' & highLight then _=hLl || _ || hLr
 
/*──────────────────────────────────.EF subroutine──────────────────────*/
if _==' ' & ,
ef: if ?.f\=='' then call er 61, '.F= .EF=' /*conflicting options.*/
showposs then do
?.f = ?.ef
jrjc=jr || jc
return
showit=anyshow
if showcell\=='' then if wordpos(jrjc,showcell)\==0 then showit=1
if showcol\=='' then if pos(jc,showcol)\==0 then showit=1
if showrow\=='' then if pos(jr,showrow)\==0 then showit=1
 
/*──────────────────────────────────.F subroutine───────────────────────*/
do jb=1 while showbox\==''
.f: _=?.f b=substr(showbox,jb,1) /*File where the text is written.*/
if !cms then do
if b==' ' then leave
_=translate(_, , '/,') /*try to translate to CMS if wordpos(jrjc,boxformat.b)\==0 then showit=1*/
if words(_)>3 then call er 10, end /*jb*/?.f
?.f = _ word(subword(_,2) !fn,1) word(subword(_,3) 'A1',1)
end
 
__=lastpos("\",_)
if showit then _=strip(left(!.jr.jc,gridwidth),'T')
if !dos & ?.ef=='' & __\==0 then call $mkdir endleft(_,__)
return
 
/*──────────────────────────────────.INV subroutine─────────────────────*/
gnum=gnum || gridbar || centre(_,gridwidth)
.inv: return x2c( b2x( translate( x2b( c2x( arg(1) ) ), 01, 10) ) )
if jc//3==0 then gnum=gnum || gridbar
end /*jc*/
 
/*──────────────────────────────────.J subroutine───────────────────────*/
call tg gnum
.j: upper ?.j /*Justify (or not) the text. */
if \short then call tg gemp
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───────────────────────*/
if jr//3==0 then do
.L: upper ?.L call tg gtail /*Line(s) for the text is shown. */
if jr\==9!cms then call tg gheaddo
'$QWHAT DSC'
if rc==4 then ?.L=0
end
else call tg grid
end /*jr*/
 
if ?.L=='CMSG' then ?.L="*"
call $t
call wn 'L',-sd(),sd()
if ?.L<0 then ?.L=sd()-?.L
return
 
/*──────────────────────────────────.O subroutine───────────────────────*/
/*─────────────────────────────validate subroutine──────────────────────*/
.o: call wn 'O',-999,999,9999
validate: /*are all empties possible?*/
 
if ?.o<0 then do
do r=1 for 9 /*step through each row. */
do c=1 for 9 /*step through each columnonlyo=-?.*/o
?.o=9999
end
return
 
/*──────────────────────────────────.P subroutine───────────────────────*/
if @.r.c==' ' & ,
.p: if !.r?.c==''q then do return /*noPost legal(writting) digitblank herelines. */
_=?.p
if arg(1)==1 then call $t sod "puzzle isn't valid !"
return 0
end
end /*c*/
end /*r*/ /*sub requires possibles. */
 
if _>98 |,
return 1 /*indicate puzzle is valid.*/
_<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
/*─────────────────────────────validall subroutine──────────────────────*/
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold
validall: /*validate all Q specified.*/
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold
end /*1*/
 
do abs(_) while _<99
do r=1 for 9 /*step through each row. */
call wit bline
do c=1 for 9 /*step through each column.*/
end /*abs*/
if @.r.c==' ' then iterate /*if blank, then it's ok. */
y= do _=1 to /*the rest of the row-?. */a
call wit bline
rc=r||c
do kc=1 for 9 end /*compare to #s in column. _*/
return
if kc\==c then y=y|| @.r.kc /*build the rest of the row*/
end /*kc*/
q=@.r.c
if pos(q,y)\==0 then return tem(r,c,'row') /*same # in same row?*/
y= /*the rest of the column. */
do kr=1 for 9 /*compare to #s in column. */
if kr\==r then y=y || @.kr.c /*build the rest of the col*/
end /*kr*/
 
/*──────────────────────────────────.RULER subroutine───────────────────*/
if pos(q,y)\==0 then return tem(r,c,'col') /*same # in same col?*/
.ruler: call wn 'RULER', -sw(), sw() /*RULER draws a "ruler" line. */
y= /*the rest of the box. */
?.rulerb = tb(?.rulerb, 'RULERB')
b=box.rc
return
 
/*──────────────────────────────────.S subroutine───────────────────────*/
do br=boxr.b to boxr.b+2 /*compare to #s of the box.*/
do bc=boxc.bs: to boxc.b+2 call wn "S", -999, 999, 999 /*buildSkip the(or restsuppress) line(s). of the box*/
if br\==r & bc\==c then y=y || @.br.bc
end /*bc*/
end /*br*/
 
if ?.s<0 then do
if pos(q,y)\==0 then return tem(r,c,'box') /*same # in same box?*/
if left(?.o,1)=='-' then /*check for conflicting options*/
end /*c*/
call er 61,"O="?.o 'S='?.s "(both can't be negative)"
end /*r*/
onlys = -?.s
?.s = 0
end
 
if left(?.o,1)=="-" & left(?.s,1)=='-' then
return 1 /*indicate all are valid.*/
call er 61,"O="?.o 'S='?.s "(both can't be negative)"
return
 
/*──────────────────────────────────.SCALE subroutine───────────────────*/
/*─────────────────────────────validx subroutine────────────────────────*/
.scale: call wn 'SCALE', -sw(), sw() /*SCALE draws a "scale" line. */
validx: arg r,c
?.scaleb = tb(?.scaleb, 'SCALEB')
rc=r || c
?.scaled = tb(?.scaled, 'SCALED', ".")
y= /*the rest of the row. */
?.scalep = tb(?.scalep, 'SCALEP', "+")
do kc=1 for 9 /*compare to #s in column. */
return
if kc\==c then y=y || @.r.kc /*build the rest of the row*/
end /*kc*/
 
/*──────────────────────────────────.T subroutine───────────────────────*/
q=@.r.c /*get the digit at r,c */
.t: call wn 'T', 0, 99 /*Times the text is written. */
if pos(q,y)\==0 then return tem(r,c,'row') /*same number in same row ?*/
if ?.ts\==0 then call wn 'TS', 0, 99
y= /*the rest of the column. */
do kr=1 for 9 ?.tsb = /*compare to #s in columntb(?.tsb, */'TSB')
return
if kr\==r then y=y || @.kr.c /*build the rest of the col*/
end /*kr*/
 
/*──────────────────────────────────.U subroutine───────────────────────*/
if pos(q,y)\==0 then return tem(r,c,'col') /*same # in same column ?*/
y= .u: upper ?.u /*thehandle restuppercasing oftext the boxparts. */
?.u = left(?.u, 1)
b=box.rc
if pos(?.u, " AFLUW")==0 then call er 55, ?.u '.U='
if ?.u==' ' | ?.u=='A' then ?.u=
return
 
/*──────────────────────────────────.UT subroutine──────────────────────*/
do br=boxr.b to boxr.b+2 /*compare to #s of the box.*/
.ut: call wn 'T', 0, 99 do bc=boxc.b to boxc.b+2 /*buildTimes the resttext is written. of the box*/
if br?.ut==r & bc==c thenvaln(?.ut, iterate"UT")
y=y || @.br.bc
end /*br*/
end /*bc*/
 
if length(?.ut)//2==1 then
if pos(q,y)\==0 then return tem(r,c,'box') /*same # in same box ? */
return 1 call er /*indicate X (r30,c)?.ut is'translate-characters valid*/an-even-number-of'
return
 
/*──────────────────────────────────.V subroutine───────────────────────*/
/*─────────────────────────────pruneposs subroutine─────────────────────*/
.v: upper ?.v /*video mode, Normal -or- Reverse*/
pruneposs: if \(prunesing | pruneexcl | prunemats | pruneline) then return
?.v=left(?.v, 1)
call buildposs
if pos(?.v, " NR")==0 then call er 55, ?.v '.V='
if ?.v==' ' | ?.v=='N' then ?.v=
return
 
/*──────────────────────────────────.W subroutine───────────────────────*/
do prunes=1
.w: if ?.q then return
call $t !fn 'is starting prune pass #' prunes
if ?.wb\=='' then ?.wb=tb(?.wb, 'WB')
found=0 /*indicate no prunes so far*/
 
ww=translate(?.w,,"_")
if prunesing then do /*prune puzzle for singles.*/
if ww='dd'x then ww _=prunesing() /*find"press any singles ? key to continue */..."
if ww='de'x then ww found=found |"press _the ENTER key to continue /*track if anything found. */.."
call '$T' ".C=yel" translate(ww,?.wb,' ')
if _ then if showgrid then call showgrid /*show grid*/
if ww='dd'x then call endinkey
if ww='de'x then pull external
return
 
/*──────────────────────────────────.X subroutine───────────────────────*/
if pruneexcl then do /*prune puzzle for singles.*/
.x: call wn 'X', -sw(), sw()
_=pruneexcl() /*find any excluives ? */
x2 = copies(?.xb, abs(?.x))
found=found | _ /*track if anything found. */
if _?.x<0 then if showgrid then call showgrid /*show grid*/x1=x2
LLx = length(x1 || endx2)
return
 
/*──────────────────────────────────.XK subroutine──────────────────────*/
if pruneonly then do /*prune puzzle for onlys. */
.xk: do ##=1
_=pruneonly() /*find any onlys ? */
parse var @ found=found | _ (xk) /*track if anything found. */@
if _=='' then if& showgrid then@=="" call showgrid /*showthen grid*/leave
tx.## = end_
if @\=='' then tx.## = tx.## || ?.k
tx.## = strip(tx.##)
LLk = max(LLk, length(tx.##))
end /*##*/
##=##-1
return
 
/*──────────────────────────────────.Z subroutine───────────────────────*/
if prunemats then do jpm=2 to 8 /*prune puzzle for matches.*/
.z: __z=prunematsword(arg(jpm1) ?.z, 1) /*findsnore subroutine: zzzzzz... any matches (len=j)?*/
if _z=0 then return
found=found | _ /*track if anything found. */
if _!cms then if showgrid then call showgridcp 'SLEEP' /*show_z grid*/"SEC"
if !dos then call delay end_z
return
 
/*──────────────────────────────────BEEPS subroutine────────────────────*/
if pruneline then do /*prune puzzle for lines. */
beeps: if \!dos & !pcrexx then return /*can this OS handle sounds? */
_=pruneline() /*find 2 or more on a line?*/
found=found | _ /*track if anything found. */
if _ then if showgrid then call showgrid /*show grid*/
end
 
do jb=1 for abs(arg(1))
if \found then leave /*nothing found this time ?*/
if jb\==1 then call delay .1
end /*prunes*/
 
do jb_=1 for words(?.bf)
call sound word(?.bf, jb_), word(word(?.bd,jb_) .2,1)
end /*jb_*/
end /*jb */
return
 
/*──────────────────────────────────BLOCKER subroutine──────────────────*/
/*─────────────────────────────prunesing subroutine─────────────────────*/
blocker: do jc=1 for LL /*process some blocked characters*/
prunesing: foundsing=0
chbit.jc = $block(substr(_, jc, 1))
end /*jc*/
bcl = ?.block
bcs = 1
 
if bcl<0 then do
do r=1 for 9
do c=1 for 9 bcl=-bcl
_=length(!.r.c) /*get length of possible. bcs=3*/bcl-2
if _==0 then iterate /*if null, then ignore it. */end
if _\==1 then iterate /*if not one digit, ignore.*/
@.r.c=!.r.c /*it's 1 digit, a solution.*/
!.r.c= /*erase the old possible. */
foundsing=1
call $t !fn 'found a single digit at cell' drc(r,c,@.r.c)
end /*c*/
end /*r*/
 
if _=='' then _=' '
if foundsing then call buildposs /*re-build the possibles. */
tbc = ?.bc
return foundsing
if tbc=='' then tbc=_
tbc = left(copies(tbc,1+sw()%length(tbc)),sw())
 
do jl=bcs to 3*bcl by 3
/*─────────────────────────────pruneexcl subroutine─────────────────────*/
_ = copies(?.bb, max(1, 12*LL+?.bs*LL-?.bs))
pruneexcl: foundexcl=0
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
do exclusives=1 /*keep building possibles. */
do r=1 for 9
do c=1 for 9
z=!.r.c
lz=length(z) /*get length of possible. */
if lz==0 then iterate /*if null, then ignore it. */
y=
rc=r || c
b=box.rc
 
/*──────────────────────────────────COLORS subroutine───────────────────*/
do br=boxr.b to boxr.b+2 /*compare to #s of the box.*/
colors: arg hue,__,cc#,cc do bc=boxc.b to boxc.b+2 /*build the rest ofverify/handle thesynonymous boxcolors*/
dark = left(hue,4)=='DARK'
if br==r & bc==c then iterate
if dark y=y || @.br.bc || !.br.bc then hue = substr(hue,5)
if hue=='BRITE' | hue=="BRIGHT" then hue = 'WHITE'
end /*bc*/
if left(hue,5)=='BRITE' then hue = end /*br*/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
/*test for reduction. */
ahue=word(hues,jj)
do t=1 for lz
if abbrev(ahue,hue,3) then do
q=substr(z,t,1)
cc=word(hues,jj+1)
hue=ahue
leave
end
end /*jj*/
 
if cc=='' then call er 50, "color" '.'__"="hue
if pos(q,y)==0 then do
if dark & left(cc,2)=='1;' then cc="0"substr(cc,2)
foundexcl=1
@.r.c=q /*it's a singularity, a sol*/
!.r.c= /*erase old possibleity. */
call $t !fn 'found the digit' q,
"by exclusiveness at cell" drc(r,c,z)
call buildposs /*re-build the possibles. */
iterate exclusives
end
end /*t*/
end /*c*/
end /*r*/
 
if !cms then do
leave
if hue='GRAY' | hue=="BLACK" then hue='WHITE'
end /*exclusives*/
if hue="BROWN" then hue='YELLOW'
end
 
color.cc# = hue
return foundexcl
colorC.cc# = esc || cc'm'
return
 
/*──────────────────────────────────CPMORE subroutine───────────────────*/
/*─────────────────────────────prunemats subroutine─────────────────────*/
prunematscpMore: foundmatch=0 call cp 'QUERY TERM', 9 /*no matchesparse foundCP soTERMINAL far.for MORE,HOLD*/
__=
parse arg L /*length of match, L=2,pair*/
do jj=1 for cp.0
__=__ cp.jj
end /*jj*/
 
parse upper var __ 'MORE' more ',' 1 'HOLD' hold ','
do matches=1
if _>9998 & more\=='' then call cp 'TERMINAL MORE 0 0'
do r=1 for 9
if _>99999998 & hold\=='' then call cp 'TERMINAL HOLD OFF'
do c=1 for 9
return
_=length(!.r.c) /*get length of possible. */
if _==0 then iterate /*if null, then ignore it. */
if _\==L then iterate /*not right length, ignore.*/
qq=!.r.c
m=0 /*count of matches so far. */
do _c=1 for 9 /*nother match in same row?*/
if qq==!.r._c then m=m+1 /*up count if it's a match.*/
end /*_c*/
 
/*──────────────────────────────────DSAY subroutine─────────────────────*/
if m>=L then do pc=1 for 9 /*squish other possibles. */
dsay: if old=!.r?.pc q then return /*savedo the "old" value.SAY subroutine, write to scr*/
dsay_ = strip(translate(arg(1), , '0'x), 'T')
if old==qq then iterate /*if match, then ignore it.*/
say dsay_
if old=='' then iterate /*if null poss, then ignore*/
LLd = new=squishlength(old,qqdsay_) /*removelength mat'sof digslast fromline Xdisplayed. */
return
if new==old then iterate /*if no change,keep looking*/
!.r.pc=new /*store new value into old.*/
foundmatch=1 /*indicate match was found.*/
call $t !fn 'is removing a' old "from" drc(r,pc,old),
'because of a match at' drc(r,c,qq)
if length(new)==1 then do /*reduce if L=1*/
@.r.pc=new /*store single.*/
!.r.pc= /*delete poss. */
call buildposs /*re-build poss*/
iterate matches /*start over.*/
end
end /*pc*/
m=0 /*count of matches so far. */
 
/*──────────────────────────────────HIGHLIGHT subroutine────────────────*/
do _r=1 for 9 /*nother match in same col?*/
highLight: do _=1 for 7
if qq==!._r.c then m=m+1 /*up count if it's a match.*/
endhhl._ = /*_r*/color._\==''
hics._ = left(hh._,1)
hice._ = right(hh._,1)
 
if m>=L then do pr=1 for 9if hhl._ then /*squish other possibles. */do
old=!.pr.c minhic= min(_,minhic); shics= shics || /*save the "old" valuehics. */_
if old==qq then iterate /*if match maxhic= max(_,maxhic); ehics= thenehics ignore|| ithice.*/_
if old=='' then iterate /*if null poss, then ignore*/end
new=squish(old,qq) end /*remove mat's digs from X._*/
if new==old then iterate /*if no change,keep looking*/
!.pr.c=new /*store new value into old.*/
foundmatch=1 /*indicate match was found.*/
call $t !fn 'is removing a' old "from" drc(pr,c,old),
'because of a match at' drc(r,c,qq)
if length(new)==1 then do /*reduce if L=1*/
@.pr.c=new /*store single.*/
!.pr.c= /*delete poss. */
call buildposs /*re-build poss*/
iterate matches /*start over.*/
end
end /*pr*/
end /*c*/
end /*r*/
 
ahics=shics || ehics
leave
return
end /*matches*/
 
/*──────────────────────────────────HUE subroutine──────────────────────*/
return foundmatch
hue: hue#=max(1, hue#+arg(1))
__=arg(2)
if __\=='' then hue.hue#=__
_=
return
 
/*──────────────────────────────────INCHES Subroutine───────────────────*/
/*─────────────────────────────pruneonly subroutine─────────────────────*/
pruneonlyinches: foundmatch=0 /*nohandle matches foundRULER soand far.SCALE stuff.*/
_ = kw('RULERB') kw('SCALEB') kw('SCALEP') kw('SCALED')
 
if arg(2) then _=$scale(?.scale _ 'Q')
do findonlys=1 /*keep searching ... */
else _=$scale(?.ruler 'RULE' _ 'Q')
_row.= /*build str for each row . */
 
parse var _ do r=_.1 '9'x for_.2 '9'x _.3
do c=1 for 9
if !.r.c\=='' then _row.r=_row.r !.r.c
end /*c*/
end /*r*/
 
_col.= do jk=1 /*build str for each boxcol*/3
_=_.jk
if _\=='' then call wit _
end /*jk*/
return
 
/*──────────────────────────────────MS subroutine───────────────────────*/
do c=1 for 9
ms: #ms=#ms+1 do r=1 for 9 /*justification and indentation. */
parse arg _i
if !.r.c\=='' then _col.c=_col.c !.r.c
end /*r*/
end /*c*/
 
select
do r=1 for 9
when ?.j=='' do c=1 forthen 9nop
when ?.N=='N' then nop
q=!.r.c
when length(_i)>=sw()-1 then nop
if q=='' then iterate /*if empty, then ignore it.*/
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')
do j=1 to length(q) /*step through each digit. */
return
k=substr(q,j,1)
 
/*──────────────────────────────────SAYALINE subroutine──────────────────*/
if kount1(k,_row.r) |, /*is this the ONLY digit K?*/
sayAline:
kount1(k,_col.c) then do i=1 to length(q) /*prune others.*/
foundmatch=1
_=substr(q,i,1)
if _==k then iterate /*if=K, ignore.*/
o=squish(q,_) /*remove others*/
!.r.c=o
call $t !fn 'removed part of an only',
_ "from cell" drc(r,c,q)
if length(o)==1 then /*reduce if L=1*/
do
@.r.c=o /*store single.*/
!.r.c= /*delete poss. */
call buildposs /*re-build poss*/
iterate findonlys /*start over. */
end
end /*i*/
end /*j*/
end /*c*/
end /*r*/
 
do jj=?.s to #ms for ?.o
leave
if skp() then iterate
end /*findonlys*/
 
if \?.q then do
return foundmatch
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
/*─────────────────────────────pruneline subroutine─────────────────────*/
pruneline: foundmatch=0 /*no matches found so far. */
 
/*──────────────────────────────────SAYBRITE subroutine─────────────────*/
do findlines=1 /*keep searching ... */
sayBrite: do jj=?.s to #ms for ?.o
_boxr.= /*build str for each boxrow*/
if skp() then iterate
call wr _mm
if ?.q then iterate
 
doif !cms r=1 then for'$CLEAR .C=BRITE' 9_mm
do c=1 for 9 else if !dos then call dsay colorC.0 || _mm || scr0
end rc=r || c/*jj*/
return
b=box.rc
if !.r.c\=='' then _boxr.r.b=strip(_boxr.r.b !.r.c)
end /*c*/
end /*r*/
 
/*──────────────────────────────────SAYNLINE subroutine─────────────────*/
_boxc.= /*build str for each boxcol*/
sayNline: do jj=?.s to #ms for ?.o
if skp() then iterate
 
doif !dos c=1then for 9do
do r if ?.c=1='' then call fordsay 9_mm
rc=r else call dsay colorC.0 || _mm || cscr0
b=box.rc call wr _mm
if !.r.c\=='' then _boxc.c.b=strip(_boxc.c.b !.r.c) end
end /*r*/ else call wit _mm
end /*cjj*/
return
 
/*──────────────────────────────────SAYHIGHLIGHT subroutine─────────────*/
do r=1 for 9 /*search all rows for twins*/
sayHighlight:
 
do bjj=rowlb?.rs to rowhb.r#ms /*for each row, search box?.*/o
if skp() then iterate
aline=_boxr.r.b /*get a row in the box. */
if aline=='' then iterate /*if empty, ignore the line*/
w=words(aline) /*W is # of words in aline*/
if w<2 then iterate /*if < 2 words, ignore line*/
 
if !cms then do
do k=1 for 9 /*search for each digit. */
f=pos(k,aline) if \?.q then '$CLEAR .C=HIGHL' /*pos of the 1st digit: k */_mm
if f==0 then iterate /*no dig k, so keep looking*/iterate
s=pos(k,aline,f+1) /*pos of the 2nd digit: k */end
if s==0 then iterate /*no 2nd k, so keep looking*/
 
lenmm=length(_mm)
do jr=rowlb.r to rowhb.r /*look at the other 2 rows.*/
__=verify(_mm,ahics,'M')
if jr==r then iterate /*if the same row, ignore. */
if pos(k,_boxr.jr.b)\==0 then iterate k /*if no digit K, ignore*/
end /*jr*/
/*found 2 Ks in row R box B*/
do jb=rowlb.r to rowhb.r /*search boxes row R for K.*/
if jb==b then iterate /*ignore if in the same box*/
if pos(k,_boxr.r.jb)==0 then iterate
foundmatch=1 /*found a K in col C box JB*/
 
if __==0 then hc=lenmm+1
do kc=1 for 9 /*find which cell K is in.*/
rc=r || kcelse hc=__
_xx=hue.1
if box.rc==b then iterate /*ignore if in the same box*/
if hc>1 then _xx=_xx || left(_mm, _=!.r.kchc-1)
if _=='' then iterate /*ignore if no possible. */
if pos(k,_)==0 then iterate /*if no digit K, ignore. */
call $t !fn 'is row-line pruning digit' k,
'from cell' drc(r,kc,!.r.kc)
!.r.kc=squish(_,k) /*remove mat's digs from X.*/
if length(!.r.kc)==1 then do /*pruned down to one digit?*/
@.r.kc=!.r.kc /*make a true digit*/
!.r.kc= /*erase possibility*/
call buildposs /*rebuild possibles*/.
iterate findlines
end
end /*kc*/
end /*jb*/
end /*k*/
end /*b*/
end /*r*/
 
do jl=hc to lenmm
do c=1 for 9 /*search all cols for twins*/
_=substr(_mm,jl,1)
 
do jc=minhic to maxhic
do b=collb.c to colhb.c by 3 /*for each col, search box.*/
if hhl.jc then if _==hics.jc then call hue 1, colorC.jc
aline=_boxc.c.b /*get a column in the box.*/
if aline=='' then iterate /* else if empty,_==hice.jc then call ignorehue line*/-1
w=words(aline) end /*jc*/
if w<2 then iterate /*if < 2 words, ignore line*/
 
if _=='' then _xx=_xx" "
do k=1 for 9 /*search for each digit. */
__=verify(substr(_mm, jl+1), ahics, 'M')
f=pos(k,aline) /*pos of the 1st digit: k */
if f==0 then iterate /*no dig k, so keep looking*/
s=pos(k,aline,f+1) /*pos of the 2nd digit: k */
if s==0 then iterate /*no 2nd k, so keep looking*/
 
if __==0 then pl=lenmm-jl+1
do jc=boxlc.b to boxhc.b /*look at the other 2 cols.*/
else pl=__
if jc==c then iterate /*if the same col, ignore. */
if pos(k,_boxc.jc.b)\==0 then iterate k /*if no digit K, ignore*/
end /*jc*/
/*found 2 Ks in col C box B*/
do jb=collb.c to colhb.c by 3 /*search boxes col C for K.*/
if jb==b then iterate /*ignore if in the same box*/
if pos(k,_boxc.c.jb)==0 then iterate
foundmatch=1 /*found a K in col C box JB*/
 
if pl==1 then iterate
do kr=1 for 9 /*find which cell K is in.*/
_xx=_xx || hue.hue# || substr(_mm, jl+1, pl-1)
rc=kr || c
jl=jl+pl-1
if box.rc==b then iterate /*ignore if in the same box*/
end _=!.kr.c/*jl*/
if _=='' then iterate /*ignore if no possible. */
if pos(k,_)==0 then iterate /*if no digit K, ignore. */
call $t !fn 'is col-line pruning digit' k,
'from cell' drc(kr,c,!.kr.c)
!.kr.c=squish(_,k) /*remove mat's digs from X.*/
if length(!.kr.c)==1 then do /*pruned down to one digit?*/
@.kr.c=!.kr.c /*make a true digit*/
!.kr.c= /*erase possibility*/
call buildposs /*rebuild possibles*/.
iterate findlines
end
end /*kr*/
end /*jb*/
end /*k*/
end /*b*/
end /*c*/
 
if length(_xx)>sw() then if lenmm<=sw() then _xx = esc's'_xx || esc"u"
leave
call dsay _xx || scr0
end /*findlines*/
call wr _mm
end /*jj*/
 
return foundmatch
 
/*──────────────────────────────────SKP subroutine──────────────────────*/
/*═════════════════════════════general 1-line subs════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════*/
skp: if (onlyo\=='' & onlyo\==jj) |,
!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
(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
$fact!: procedure; parse arg x _ .; l=length(x); n=l-length(strip(x,'T',"!")); if n<=-n | _\=='' | arg()\==1 then return x; z=left(x,l-n); if z<0 | \isInt(z) then return x; return $fact(z,n)
$block: !call='$BLOCK'; call '$BLOCK' arg(1); !call=; return result
$fact: procedure; parse arg x _ .; arg ,n ! .; n=p(n 1); if \isInt(n) then n=0; if x<-n | \isInt(x) | n<1 | _ || !\=='' | arg()>2 then return x || copies("!",max(1,n)); !=1; s=x//n; if s==0 then s=n; do j=s to x by n; !=!*j; end; return !
$mkdir: !call='$MKDIR'; call '$MKDIR' arg(1); !call=; return result
$sfxa: parse arg ,s,m; arg u,c; if pos(left(s,2),u)\==0 then do j=length(s) to compare(s,c)-1 by -1; if right(u,j)\==left(c,j) then iterate; _=left(u,length(u)-j); if isNum(_) then return m*_; leave; end; return arg(1)
$scale: !call='$SCALE'; call '$SCALE' arg(1); !call=; return result
$sfxf: parse arg y; if right(y,1)=='!' then y=$fact!(y); if \isNum(y) then y=$sfxz(); if isNum(y) then return y; return $sfxm(y)
cp: "EXECIO" '0'arg(2) "CP(STEM CP. STRING" arg(1); return rc
$sfxm: parse arg z; arg w; b=1000; if right(w,1)=='I' then do; z=shorten(z); w=z; upper w; b=1024; end; p=pos(right(w,1),'KMGTPEZYXWVU'); if p==0 then return arg(1); n=shorten(z); r=num(n,f,1); if isNum(r) then return r*b**p; return arg(1)
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
$sfxz: return $sfxa($sfxa($sfxa($sfxa($sfxa($sfxa(y,'PAIRs',2),'DOZens',12),'SCore',20),'GREATGRoss',1728),'GRoss',144),'GOOGOLs',1e100)
p: return word(arg(1),1)
$t: if tops=='' then say arg(1); else do; !call=']$T'; call "$T" tops arg(1); !call=; end; return
halt: call er .1
ab: arg ab,abl; return abbrev(ab,_,abl)
abbkw: arg abbu; parse arg abbkw; return abbrev(abbu,_,abblkw c2x(abb)?.kw)
abbllower: return verifytranslate(arg(1)'a',@abc,'M'@abcu)-1
noValue: !sigl=sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl)
abbn: parse arg abbn; return abb(abbn) | abb('NO'abbn)
abnproper: procedure; arg f 2; parse arg ab,abl2 r; return abbrev(ab,_,abl)f || abbrev('NO'ab,_,abl+2)r
sd: if ?.scrdepth=='' then parse value scrsize() with ?.scrdepth ?.linesize .; return ?.scrdepth
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_()
sw: if ?.linesize=='' then ?.linesize=linesize(); return ?.linesize
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 _
syntax: !sigl=sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)
copies2: return copies(arg(1),2)
wit: call dsay arg(1); call wr arg(1); return
copies3: return copies(arg(1),3)
 
drc: procedure; parse arg r,c,p; _=r","c; if p\=='' then _=_ "("p')'; 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
 
err: call er '-'arg(1),arg(2); return ''
</lang>
erx: call er '-'arg(1),arg(2); exit ''
halt: call er .1
int: int=num(arg(1),arg(2)); if \isInt(int) then call er 92,arg(1) arg(2); return int/1
isInt: return datatype(arg(1),'W')
isNum: return datatype(arg(1),'N')
kount1: parse arg qd,string; k1=pos(qd,string); if k1==0 then return 0; return pos(qd,string,k1+1)==0
lower: return translate(arg(1),@abc,translate(@abc))
na: if arg(1)\=='' then call er 01,arg(2); parse var ops na ops; if na=='' then call er 35,_o; return na
nai: return int(na(),_o)
nail: return squish(int(translate(na(),0,','),_o))
nan: return num(na(),_o)
no: if arg(1)\=='' then call er 01,arg(2); return left(_,2)\=='NO'
noValue:!sigl=sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl)
num: procedure; parse arg x .,f,q; if x=='' then return x; if isNum(x) then return x/1; x=space(translate(x,,','),0); if \isNum(x) then x=$sfxf(x); if isNum(x) then return x/1; if q==1 then return x; if q=='' then call er 53,x f; call erx 53,x f
p: return word(arg(1),1)
pickBlank: procedure; parse arg x,y; arg xu; if xu=='BLANK' then return ' '; return p(x y)
shorten:procedure; parse arg a,n; return left(a,max(0,length(a)-p(n 1)))
simple: return translate(arg(1),'.||--%<>AV'copies('+',25),"·│║─═☼◄►↑↓┤┐└┴┬├┼┘┌╔╗╚╝╟╢╞╡╫╪╤╧╥╨╠╣")
squish: return space(translate(arg(1),,word(arg(2) ',',1)),0)
syntax: !sigl=sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)
tem: parse arg r,c,w; if tellinvalid then say '***error!*** row' r", col" c '('@.r.c") is a duplicate of another in the same" w'.'; return 0
tg: arg tg; if simple then tg=simple(tg); call $t gridindent || tg; return</lang>
 
=== REXX CHANGESTR function ===
Anonymous user
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/223725"