Rosetta Code

Sudoku/REXX: Difference between revisions

Page Discussion

Sudoku/REXX (view source)

Revision as of 08:29, 28 August 2014

518 bytes added ,  9 years ago
m
→‎$SUDOKU.REX: added whitespace, changed and added comments, split multiple-statement lines, made more readable.
m (corrected two REXX names. -- ~~~~)
m (→‎$SUDOKU.REX: added whitespace, changed and added comments, split multiple-statement lines, made more readable.)
Line 6:
<br><br>The &nbsp; '''$SUDOKU.REX''' &nbsp; REXX program makes use of &nbsp; '''$T.REX''' &nbsp; REXX program which is used to display text messages.
<br>The &nbsp; '''$T.REX''' &nbsp; REXX program is included here ──► [[$T.REX]].
<lang rexx>/*REXX*/ trace o;parse arg !;if !all(arg()) then exit;if !cms then address ''off
parse arg !
signal on halt; signal on novalue; signal on syntax
if !all(arg()) then exit
if !cms then address ''
signal on halt
signal on noValue
signal on syntax
 
ops=! /*remove extraneous blanks.*/
Line 14 ⟶ 19:
@.=' ' /*initialize grid to blanks*/
!.= /*nullify valid empty# list*/
@abc='abcdefghijklmnopqrstuvwxyz'; @abcU=@abc; upper @abcU
@abcU=@abc
upper @abcU
colors=!cms | !pcrexx | !r4 | !roo /*Are colors supported ? */
clear=1 /*option: clear the screen.*/
Line 58 ⟶ 65:
 
do while ops\=='' /*parse any and all options*/
parse var ops _1 2 1 _ . 1 _o ops; upper _
upper _
 
select
when _==',' then nop
when _1=='.' & pos("=",_)\==0 then tops=tops _o
 
when left(_,4)=='PUZZ' then /*do PUZZ (whole) placement*/
do
parse var _ '=' y; if y=='' then call er 35,'PUZZ'rc
if y=='' then call er 35,'PUZZ'rc
if length(y)>81 then call er 30,y 'PUZZ 1--->81'
 
do j=1
q=substr(y,j,1); if q==' ' then leave
if q==' ' then leave
if q=='.' then iterate
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
 
when left(_,4)=='CELL' then /*do CELL (grid) placement.*/
do
parse var _ 'CELL' rc '=' y; if y=='' then call er 35,'CELL'rc
if y=='' then call er 35,'CELL'rc
if length(rc)\==2 then call er 30,y 'CELL'rc 2
r=left(rc,1);c=right(rc,1)
c=right(rc,1)
call vern r,'CELLrow'
call vern c,'CELLcol'
Line 88 ⟶ 103:
@.r.c=y
end
 
when left(_,3)=='COL' then /*do COL (grid) placement. */
do
parse var _ 'COL' n '=' y; if y=='' then call er 35,'COL'n
if y=='' then call er 35,'COL'n
call vern n,'COL'
ly=length(y); if ly>9 then call er 30,y 'COL'n '1--->8'
if ly>9 then call er 30,y 'COL'n '1--->8'
 
do j=1 to to ly
x=substr(y,j,1)
if x=='' | x=="_" | x=='*' | x=="." then iterate
Line 100 ⟶ 118:
end /*j*/
end
 
when left(_,3)=='ROW' then /*do ROW (grid) placement. */
do
parse var _ 'ROW' n '=' y; if y=='' then call er 35,'ROW'n
if y=='' then call er 35,'ROW'n
call vern n,'ROW'
ly=length(y); if ly>9 then call er 30,y 'ROW'n '1--->8'
if ly>9 then call er 30,y 'ROW'n '1--->8'
 
do j=1 to ly
Line 113 ⟶ 134:
end /*j*/
end
 
when abbn('CLearscreen') then clear=no()
when abbn('HIGHLightsingles') then highlight=no()
Line 134 ⟶ 156:
when abbn('SHortgrid') then short=no()
when abbn('SOLvepuzzle') then solve=no()
 
otherwise call er 55,_o
end /*select*/
Line 145 ⟶ 168:
prunesing=1
end
 
aprune = , /*is there a PRUNExxx on ? */
pruneexcl |,
Line 155 ⟶ 179:
hll='-'
hlr='-'
 
if colors then do
hll='('
Line 161 ⟶ 186:
end
end
 
tops=space(tops)
box.=
Line 169 ⟶ 195:
boxr.j=rr
boxc.j=cc
 
do r=rr to rr+2 /*build boxes with cell #s.*/
do c=cc to cc+2
Line 176 ⟶ 203:
end /*c*/
end /*r*/
 
box.j=strip(box.j)
end /*j*/
Line 222 ⟶ 250:
call $T _
end
 
if aprune |,
showposs then do
Line 229 ⟶ 258:
end
 
if combos==1 then call $t sod 'puzzle solved.'
else if showcomb then call $t 'combinations='comma(combos)
exit /*stick a fork in it, we're done.*/
 
Line 289 ⟶ 318:
 
do jb=1 while showbox\==''
b=substr(showbox,jb,1); if b==' ' then leave
if wordpos(jrjc,box.b)\==0' ' then showit=1leave
if argwordpos(1jrjc,box.b)\==10 then call $t sod "puzzle isn't valid !"showit=1▼
end /*jb*/
 
Line 318 ⟶ 348:
do r=1 for 9 /*step through each row. */
do c=1 for 9 /*step through each column.*/
 
if @.r.c==' ' & !.r.c=='' then do /*no legal digit here. */
if @.r.c==' ' & ,
▲ if arg(1)==1 then call $t sod "puzzle isn't valid !"
!.r.c=='' then do /*no legal digit here. return 0 */
if arg(1)==1 then call $t sod "puzzle isn't valid end!"
return 0
end
end /*c*/
end /*r*/ /*sub requires possibles. */
Line 368 ⟶ 400:
if kc\==c then y=y || @.r.kc /*build the rest of the row*/
end /*kc*/
 
q=@.r.c /*get the digit at r,c */
if pos(q,y)\==0 then return tem(r,c,'row') /*same number in same row ?*/
Line 375 ⟶ 408:
end /*kr*/
 
if pos(q,y)\==0 then return tem(r,c,'col') /*same # in same colcolumn ?*/
y= /*the rest of the box. */
b=box.rc
 
Line 396 ⟶ 429:
call $t !fn 'is starting prune pass #' prunes
found=0 /*indicate no prunes so far*/
 
if prunesing then do /*prune puzzle for singles.*/
_=prunesing() /*find any singles ? */
found=found | _ /*track if anything found. */
if _ then if showgrid then call showgrid /*show grid?*/
end
 
if pruneexcl then do /*prune puzzle for singles.*/
_=pruneexcl() /*find any excluives ? */
found=found | _ /*track if anything found. */
if _ then if showgrid then call showgrid /*show grid?*/
end
 
if pruneonly then do /*prune puzzle for onlys. */
_=pruneonly() /*find any onlys ? */
found=found | _ /*track if anything found. */
if _ then if showgrid then call showgrid /*show grid?*/
end
 
if prunemats then do jpm=2 to 8 /*prune puzzle for matches.*/
_=prunemats(jpm) /*find any matches (len=j)?*/
found=found | _ /*track if anything found. */
if _ then if showgrid then call showgrid /*show grid?*/
end
 
if pruneline then do /*prune puzzle for lines. */
_=pruneline() /*find 2 or more on a line?*/
found=found | _ /*track if anything found. */
if _ then if showgrid then call showgrid /*show grid?*/
end
 
if \found then leave /*nothing found this time ?*/
end /*prunes*/
Line 430 ⟶ 469:
 
do r=1 for 9
do c=1 for 9; _=length(!.r.c) /*get length of possible. */
_=length(!.r.c) /*get length of possible. */
if _==0 then iterate /*if null, then ignore it. */
if _\==1 then iterate /*if not one digit, ignore.*/
Line 448 ⟶ 488:
do exclusives=1 /*keep building possibles. */
do r=1 for 9
do c=1 for 9; z=!.r.c
z=!.r.c
lz=length(z) /*get length of possible. */
if lz==0 then iterate /*if null, then ignore it. */
Line 454 ⟶ 495:
rc=r || c
b=box.rc
 
do br=boxr.b to boxr.b+2 /*compare to #s of the box.*/
do bc=boxc.b to boxc.b+2 /*build the rest of the box*/
Line 460 ⟶ 502:
end /*bc*/
end /*br*/
 
/*test for reduction. */
do t=1 for lz; q=substr(z,t,1)
q=substr(z,t,1)
 
if pos(q,y)==0 then do
foundexcl=1
Line 486 ⟶ 531:
do matches=1
do r=1 for 9
do c=1 for 9; _=length(!.r.c) /*get length of possible. */
_=length(!.r.c) /*get length of possible. */
if _==0 then iterate /*if null, then ignore it. */
if _\==L then iterate /*not right length, ignore.*/
Line 503 ⟶ 549:
!.r.pc=new /*store new value into old.*/
foundmatch=1 /*indicate match was found.*/
call $t !fn 'is removing a' L "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.*/
Line 513 ⟶ 559:
end /*pc*/
m=0 /*count of matches so far. */
 
do _r=1 for 9 /*nother match in same col?*/
if qq==!._r.c then m=m+1 /*up count if it's a match.*/
end /*_r*/
 
if m>=L then do pr=1 for 9 /*squish other possibles. */
old=!.pr.c /*save the "old" value. */
if old==qq then iterate /*if match, then ignore it.*/
Line 547 ⟶ 594:
do findonlys=1 /*keep searching ... */
_row.= /*build str for each row . */
 
do r=1 for 9
do c=1 for 9; if !.r.c\=='' then _row.r=_row.r !.r.c
if !.r.c\=='' then _row.r=_row.r !.r.c
end /*c*/
end /*r*/
 
_col.= /*build str for each boxcol*/
 
do c=1 for 9
do r=1 for 9; if !.r.c\=='' then _col.c=_col.c !.r.c
if !.r.c\=='' then _col.c=_col.c !.r.c
end /*r*/
end /*c*/
 
do r=1 for 9
do c=1 for 9; q=!.r.c
q=!.r.c
if q=='' then iterate /*if empty, then ignore it.*/
 
Line 571 ⟶ 624:
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
Line 595 ⟶ 648:
do findlines=1 /*keep searching ... */
_boxr.= /*build str for each boxrow*/
 
do r=1 for 9
do c=1 for 9; rc=r || c; b=box.rc
rc=r || c
b=box.rc
if !.r.c\=='' then _boxr.r.b=strip(_boxr.r.b !.r.c)
end /*c*/
end /*r*/
 
_boxc.= /*build str for each boxcol*/
 
do c=1 for 9
do r=1 for 9; rc=r || c; b=box.rc
rc=r || c
b=box.rc
if !.r.c\=='' then _boxc.c.b=strip(_boxc.c.b !.r.c)
end /*r*/
Line 608 ⟶ 668:
 
do r=1 for 9 /*search all rows for twins*/
 
do b=rowlb.r to rowhb.r /*for each row, search box.*/
aline=_boxr.r.b; if aline=='' then iterate /*ifget a row in the empty,box. ignore line*/
w=words(aline); if w<2aline=='' then iterate /*if < 2 wordsempty, ignore the line*/
w=words(aline) /*W is # of words in aline*/
if w<2 then iterate /*if < 2 words, ignore line*/
 
do k=1 for 9 /*search for each digit. */
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*/
 
do jr=rowlb.r to rowhb.r /*look at the other 2 rows.*/
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*/
Line 631 ⟶ 694:
rc=r || kc
if box.rc==b then iterate /*ignore if in the same box*/
_=!.r.kc; if _=='' then iterate /*ignore if no possible. */
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?*/
Line 649 ⟶ 713:
 
do c=1 for 9 /*search all cols for twins*/
 
do b=collb.c to colhb.c by 3 /*for each col, search box.*/
aline=_boxc.c.b; if aline=='' then iterate /*ifget a column empty,in ignorethe linebox.*/
w=words(if aline);=='' then iterate if w<2 then iterate /*if < 2 wordsempty, ignore line*/
w=words(aline)
if w<2 then iterate /*if < 2 words, ignore line*/
 
do k=1 for 9 /*search for each digit. */
Line 672 ⟶ 739:
rc=kr || c
if box.rc==b then iterate /*ignore if in the same box*/
_=!.kr.c;if _=='' then iterate /*ignore if no possible. */
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*/
Line 694 ⟶ 762:
return foundmatch
 
/*═════════════════════════════general 1-line subs══════════════════════*/
/*═════════════════════════════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))
$fact!: procedure;parse arg x _ .;l=length(x);n=l-length(strip(x,'T',"!"));if n<=-n|_\==''|arg()\==1 then return x;z=left(x,l-n);if z<0|\isint(z) then return x;return $fact(z,n)
$fact: procedure;parse arg x _ .;arg ,n ! .;n=p(n 1);if \isint(n) then n=0;if x<-n|\isint(x)|n<1|_||!\==''|arg()>2 then return x||copies("!",max(1,n));!=1;s=x//n;if s==0 then s=n;do j=s to x by n;!=!*j;end;return !
$sfxa: parse arg ,s,m;arg u,c;if pos(left(s,2),u)\==0 then do j=length(s) to compare(s,c)-1 by -1;if right(u,j)\==left(c,j) then iterate;_=left(u,length(u)-j);if isnum(_) then return m*_;leave;end;return arg(1)
$sfxf: parse arg y;if right(y,1)=='!' then y=$fact!(y);if \isnum(y) then y=$sfxz();if isnum(y) then return y;return $sfxm(y)
$sfxm: parse arg z;arg w;b=1000;if right(w,1)=='I' then do;z=shorten(z);w=z;upper w;b=1024;end;p=pos(right(w,1),'KMGTPEZYXWVU');if p==0 then return arg(1);n=shorten(z);r=num(n,f,1);if isnum(r) then return r*b**p;return arg(1)
$sfxz: return $sfxa($sfxa($sfxa($sfxa($sfxa($sfxa(y,'PAIRs',2),'DOZens',12),'SCore',20),'GREATGRoss',1728),'GRoss',144),'GOOGOLs',1e100)
$t: if tops=='' then say arg(1);else do;!call=']$T';call "$T" tops arg(1);!call=;end;return
ab: arg ab,abl;return abbrev(ab,_,abl)
abb: arg abbu;parse arg abb;return abbrev(abbu,_,abbl(abb))
abbl: return verify(arg(1)'a',@abc,'M')-1
abbn: parse arg abbn;return abb(abbn)|abb('NO'abbn)
abn: arg ab,abl;return abbrev(ab,_,abl)|abbrev('NO'ab,_,abl+2)
comma: procedure;parse arg _,c,p,t;c=pickblankpickBlank(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 _
copies2: return copies(arg(1),2)
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 ''
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'
novaluenoValue:!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)
pickblankpickBlank: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>
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/223712"