Sudoku/REXX
REXX
REXX: Version 1
This is the $SUDOKU.REX (REXX) program and is used to solve the Rosetta Code task of "sudoku".
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),
and to partially solve the puzzle using distinct strategies (separately or in combination). One option is to solve the puzzle.
The help for the $SUDOKU REXX program is included here ──► Sudoku/REXX#REXX_Version_1_Help.
The $SUDOKU.REX REXX program makes use of $ERR.REX REXX program which is used to display error messages (via $T.REX).
The $ERR.REX REXX program is included here ──► Sudoku/REXX#REXX_Version_1_Errors.
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 ──► Sudoku/REXX#REXX_CHANGESTR_function.
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. */
trace off
parse arg !
if !all(arg()) then exit
if !cms then address
signal on halt
signal on noValue
signal on syntax
ops=! /*remove extraneous blanks.*/ numeric digits 20 combos=1 @.=' ' /*initialize grid to blanks*/ !.= /*nullify valid empty# list*/ @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.*/
gridindents=3 /*# spaces grid is indented*/ gridindent=left(,gridindents) /*spaces indented for grid.*/ gridwidth=7 /*grid cell interior width.*/ gridbar='b3'x /*bar for the grid (cells).*/ gridlt='da'x /*grid cell left top. */ gridrt='bf'x /*grid cell right top. */ gridlb='c0'x /*grid cell left bottom. */ gridrb='d9'x /*grid cell right bottom. */ gridline='c4'x /*grid cell line (hyphen). */ gridlin=copies(gridline,gridwidth) /*grid cell total line. */ gridemp=left(,gridwidth) /*grid cell empty (spaces).*/ griddj='c2'x /*grid cell 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 any and all options*/ parse var ops _1 2 1 _ . 1 _o ops upper _
select when _==',' then nop when _1=='.' & pos("=",_)\==0 then tops=tops _o
when abb('PUZzle') then /*do PUZZ (whole) placement*/ do puzz=na() if length(puzz)>81 then call er 30,puzz 'PUZZLE 1───►81'
do j=1 for length(puzz) q=substr(puzz,j,1) 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 _=='CELL' then /*do CELL (grid) placement.*/ do rc=nai() if length(rc)\==2 then call er 30,y 'CELL'rc 2 y=na() if length(y)>1 then call er 30,y 'CELL'rc 1 r=left(rc,1) c=right(rc,1) call vern r,'CELLrow' call vern c,'CELLcolumn' call vern y,'CELLdigit' @.r.c=y end
when abb('COLumn') then /*do ROW (grid) placement. */ do n=nai() y=na() call vern n,'column' ly=length(y) if ly>9 then call er 30,y 'column'n '1───>9'
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 /*do ROW (grid) placement. */ do n=nai() y=na() call vern n,'row' ly=length(y) if ly>9 then call er 30,y 'row'n '1───>9'
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_row_'n @.n.j=x end /*j*/ end
when abbn('CLearscreen') then clear=no() when abbn('HIGHLightsingles') then highLight=no() when abbn('PRUNEALL') then pruneall=no() when abbn('PRUNEONLYs') then pruneonly=no() when abbn('PRUNEEXclusives') then pruneexcl=no() when abbn('PRUNELINEs') then pruneline=no() 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()
otherwise call er 55,_o end /*select*/ end /*while ops¬==*/
if solve then pruneall=1 /*if solving, use PRUNEALL.*/
if pruneall then do /*if pruneAll, set ON other*/
pruneexcl=1 pruneonly=1 pruneline=1 prunemats=1 prunesing=1 end
aprune = , /*is there a PRUNExxx on ? */
pruneexcl |, pruneonly |, pruneline |, prunemats |, prunesing
if highLight then do /*HIGHLIGHTSINGLES opt on? */
hLl='-' hLr='-'
if colors then do hLl='(' hLr=')' tops='.H=yell' tops end end
tops=space(tops) box.=
do j=1 for 9 /*build the box bounds. */ rr=(((j*3)%10)+1)*3-2 /*compute row lower bound. */ cc=(((j-1)//3)+1)*3-2 /*compute col lower bound. */ boxr.j=rr boxc.j=cc
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*/
box.j=strip(box.j) end /*j*/
rowlb.=10 /*row R, low box number=b.*/ 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 r=1 for 9 do c=1 for 9 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*/
do j=1 to 9 /*for each box, row, col...*/ rowhb.j=rowlb.j+2 /*compute row's high box #.*/ 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 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 showoneline then do /*show grid as line line ? */
_= /*start with a clean slate.*/ do r=1 for 9 do c=1 for 9 _=_ || @.r.c /*build the string ... */ end /*c*/ end /*r*/
_=translate(strip(_,'T'),".",' ') if showinfo then call $T 'one-line grid:' call $T _ end
if aprune |,
showposs then do call pruneposs /*go build poss, then prune*/ if showposs then call showgrid 'possibles' /*show grid.*/ if \validate(1) then exit /*validate the puzzle. */ 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.*/
/*─────────────────────────────vern subroutine──────────────────────────*/ vern: parse arg v,w /*verify a digit for an opt*/ if v== then call er 35,v w if \isInt(v) then call er 92,v w if v<1 | v>9 then call er 81,1 9 v w return
/*─────────────────────────────buildposs subroutine─────────────────────*/ buildposs: !.= /*nullify possibilities. */ combos=1
do rp=1 for 9 /*build table of valid #s. */ do cp=1 for 9 /*step through each column.*/ if @.rp.cp\==' ' then iterate /*not blank? Keep looking.*/
do jd=1 for 9 /*try each digit. */ @.rp.cp=jd if validx(rp,cp) then !.rp.cp=!.rp.cp || jd end /*jd*/
combos=combos*length(!.rp.cp) /*calculate # combinations.*/ @.rp.cp=' ' /*restore the point (blank)*/ end /*cp*/ end /*rp*/
return
/*─────────────────────────────showgrid subroutine──────────────────────*/ showgrid: parse arg title 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)\==)
do jr=1 for 9 if \short then call tg gemp gnum=
do jc=1 for 9 _=@.jr.jc if _\==' ' & highLight then _=hLl || _ || hLr
if _==' ' & , showposs then do jrjc=jr || jc 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
do jb=1 while showbox\== b=substr(showbox,jb,1) if b==' ' then leave if wordpos(jrjc,box.b)\==0 then showit=1 end /*jb*/
if showit then _=strip(left(!.jr.jc,gridwidth),'T') end
gnum=gnum || gridbar || centre(_,gridwidth) if jc//3==0 then gnum=gnum || gridbar end /*jc*/
call tg gnum if \short then call tg gemp
if jr//3==0 then do call tg gtail if jr\==9 then call tg ghead end else call tg grid end /*jr*/
call $t return
/*─────────────────────────────validate subroutine──────────────────────*/ validate: /*are all empties possible?*/
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 arg(1)==1 then call $t sod "puzzle isn't valid !" return 0 end end /*c*/ end /*r*/ /*sub requires possibles. */
return 1 /*indicate puzzle is valid.*/
/*─────────────────────────────validall subroutine──────────────────────*/ validall: /*validate all Q specified.*/
do r=1 for 9 /*step through each row. */ do c=1 for 9 /*step through each column.*/ if @.r.c==' ' then iterate /*if blank, then it's ok. */ y= /*the rest of the row. */ rc=r||c do kc=1 for 9 /*compare to #s in column. */ 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*/
if pos(q,y)\==0 then return tem(r,c,'col') /*same # in same col?*/ y= /*the rest of the box. */ 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*/ if br\==r & bc\==c then y=y || @.br.bc end /*bc*/ end /*br*/
if pos(q,y)\==0 then return tem(r,c,'box') /*same # in same box?*/ end /*c*/ end /*r*/
return 1 /*indicate all are valid.*/
/*─────────────────────────────validx subroutine────────────────────────*/ validx: arg r,c rc=r || c y= /*the rest of the row. */
do kc=1 for 9 /*compare to #s in column. */ 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 ?*/ 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*/
if pos(q,y)\==0 then return tem(r,c,'col') /*same # in same column ?*/ y= /*the rest of the box. */ 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*/ if br==r & bc==c then iterate y=y || @.br.bc end /*br*/ end /*bc*/
if pos(q,y)\==0 then return tem(r,c,'box') /*same # in same box ? */ return 1 /*indicate X (r,c) is valid*/
/*─────────────────────────────pruneposs subroutine─────────────────────*/ pruneposs: if \(prunesing | pruneexcl | prunemats | pruneline) then return call buildposs
do prunes=1 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*/
return
/*─────────────────────────────prunesing subroutine─────────────────────*/ prunesing: foundsing=0
do r=1 for 9 do c=1 for 9 _=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.*/ @.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 foundsing then call buildposs /*re-build the possibles. */ return foundsing
/*─────────────────────────────pruneexcl subroutine─────────────────────*/ pruneexcl: foundexcl=0
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
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*/ if br==r & bc==c then iterate y=y || @.br.bc || !.br.bc end /*bc*/ end /*br*/
/*test for reduction. */ do t=1 for lz q=substr(z,t,1)
if pos(q,y)==0 then do 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*/
leave end /*exclusives*/
return foundexcl
/*─────────────────────────────prunemats subroutine─────────────────────*/ prunemats: foundmatch=0 /*no matches found so far. */ parse arg L /*length of match, L=2,pair*/
do matches=1 do r=1 for 9 do c=1 for 9 _=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*/
if m>=L then do pc=1 for 9 /*squish other possibles. */ old=!.r.pc /*save the "old" value. */ if old==qq then iterate /*if match, then ignore it.*/ if old== then iterate /*if null poss, then ignore*/ new=squish(old,qq) /*remove mat's digs from X.*/ 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. */
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.*/ if old== then iterate /*if null poss, then ignore*/ new=squish(old,qq) /*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*/
leave end /*matches*/
return foundmatch
/*─────────────────────────────pruneonly subroutine─────────────────────*/ pruneonly: foundmatch=0 /*no matches found so far. */
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 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 end /*r*/ end /*c*/
do r=1 for 9 do c=1 for 9 q=!.r.c if q== then iterate /*if empty, then ignore it.*/
do j=1 to length(q) /*step through each digit. */ k=substr(q,j,1)
if kount1(k,_row.r) |, /*is this the ONLY digit K?*/ 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*/
leave end /*findonlys*/
return foundmatch
/*─────────────────────────────pruneline subroutine─────────────────────*/ pruneline: foundmatch=0 /*no matches found so far. */
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 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 if !.r.c\== then _boxc.c.b=strip(_boxc.c.b !.r.c) end /*r*/ end /*c*/
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 /*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*/
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*/
do kc=1 for 9 /*find which cell K is in.*/ 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 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 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 /*get a column in the box.*/ if aline== then iterate /*if empty, ignore line*/ w=words(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 jc=boxlc.b to boxhc.b /*look at the other 2 cols.*/ 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*/
do kr=1 for 9 /*find which cell K is in.*/ 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 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*/
leave end /*findlines*/
return foundmatch
/*────────────────────────────────────────────────────────────────────────────*/ commas: procedure; parse arg _; n=_'.9'; #=123456789; b=verify(n,#,"M")
e=verify(n,#'0',,verify(n,#"0.",'M'))-4 do j=e to b by -3; _=insert(',',_,j); end /*j*/; return _
/*═════════════════════════════general 1-line subs══════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════*/ !all: !!=!;!=space(!);upper !;call !fid;!nt=right(!var('OS'),2)=='NT';!cls=word('CLS VMFCLEAR CLRSCREEN',1+!cms+!tso*2);if arg(1)\==1 then return 0;if wordpos(!,'? ?SAMPLES ?AUTHOR ?FLOW')==0 then return 0;!call=']$H';call '$H' !fn !;!call=;return 1 !cal: if symbol('!CALL')\=="VAR" then !call=; return !call !env: !env='ENVIRONMENT'; if !sys=='MSDOS' | !brexx | !r4 | !roo then !env='SYSTEM'; if !os2 then !env='OS2'!env; !ebcdic=1=='f0'x; 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) 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)) no: if arg(1)\== then call er 01,arg(2); return left(_,2)\=='NO' noValue:!sigl=sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) num: procedure; parse arg x .,f,q; if x== then return x; if isNum(x) then return x/1; x=space(translate(x,,','),0); if \isNum(x) then x=$sfxf(x); if isNum(x) then return x/1; if q==1 then return x; if q== then call er 53,x f; call erx 53,x f p: return word(arg(1),1) shorten:procedure; parse arg a,n; return left(a,max(0,length(a)-p(n 1))) 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 Version 1 Output
output when using the input of:
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
$SUDOKU is showing the puzzle ┌───────┬───────┬───────┐┌───────┬───────┬───────┐┌───────┬───────┬───────┐ │ │ │ ││ │ │ ││ │ │ │ │ │ 5 │ ││ │ 7 │ ││ 8 │ 9 │ │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 9 │ │ ││ │ 3 │ ││ │ │ │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 1 │ │ ││ │ 8 │ 9 ││ │ 4 │ │ │ │ │ ││ │ │ ││ │ │ │ └───────┴───────┴───────┘└───────┴───────┴───────┘└───────┴───────┴───────┘ ┌───────┬───────┬───────┐┌───────┬───────┬───────┐┌───────┬───────┬───────┐ │ │ │ ││ │ │ ││ │ │ │ │ │ │ 9 ││ │ │ ││ │ │ 1 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ │ │ 1 ││ 3 │ │ 5 ││ 2 │ │ │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 6 │ │ ││ │ │ ││ 5 │ │ │ │ │ │ ││ │ │ ││ │ │ │ └───────┴───────┴───────┘└───────┴───────┴───────┘└───────┴───────┴───────┘ ┌───────┬───────┬───────┐┌───────┬───────┬───────┐┌───────┬───────┬───────┐ │ │ │ ││ │ │ ││ │ │ │ │ │ 6 │ ││ 8 │ 9 │ ││ │ │ 3 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ │ │ ││ │ 5 │ ││ │ │ 7 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ │ 9 │ 8 ││ │ 2 │ ││ │ 5 │ │ │ │ │ ││ │ │ ││ │ │ │ └───────┴───────┴───────┘└───────┴───────┴───────┘└───────┴───────┴───────┘ $SUDOKU is starting prune pass # 1 $SUDOKU found the digit 8 by exclusiveness at cell 2,2 (2478) $SUDOKU found the digit 3 by exclusiveness at cell 3,7 (367) $SUDOKU found the digit 5 by exclusiveness at cell 4,1 (234578) $SUDOKU found the digit 8 by exclusiveness at cell 5,1 (478) $SUDOKU found the digit 9 by exclusiveness at cell 6,4 (12479) $SUDOKU found the digit 9 by exclusiveness at cell 5,9 (469) $SUDOKU found the digit 5 by exclusiveness at cell 7,3 (2457) $SUDOKU found the digit 1 by exclusiveness at cell 8,2 (1234) $SUDOKU found the digit 9 by exclusiveness at cell 8,7 (469) $SUDOKU found the digit 8 by exclusiveness at cell 8,8 (268) $SUDOKU found the digit 8 by exclusiveness at cell 6,9 (48) $SUDOKU found the digit 8 by exclusiveness at cell 4,6 (24678) $SUDOKU found the digit 4 by exclusiveness at cell 4,7 (467) $SUDOKU found the digit 2 by exclusiveness at cell 7,8 (12) $SUDOKU found the digit 4 by exclusiveness at cell 9,9 (46) $SUDOKU found the digit 6 by exclusiveness at cell 9,7 (16) $SUDOKU found the digit 1 by exclusiveness at cell 7,7 (1) $SUDOKU found the digit 1 by exclusiveness at cell 2,8 (167) $SUDOKU found the digit 7 by exclusiveness at cell 2,7 (7) ∙ ∙ ∙ some output elided ∙∙∙ ∙ ∙ ∙ ┌───────┬───────┬───────┐┌───────┬───────┬───────┐┌───────┬───────┬───────┐ │ │ │ ││ │ │ ││ │ │ │ │ 4 │ 5 │ 3 ││ 1 │ 7 │ 6 ││ 8 │ 9 │ 2 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 9 │ 8 │ 6 ││ 4 │ 3 │ 2 ││ 7 │ 1 │ 5 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 1 │ 2 │ 7 ││ 5 │ 8 │ 9 ││ 3 │ 4 │ 6 │ │ │ │ ││ │ │ ││ │ │ │ └───────┴───────┴───────┘└───────┴───────┴───────┘└───────┴───────┴───────┘ ┌───────┬───────┬───────┐┌───────┬───────┬───────┐┌───────┬───────┬───────┐ │ │ │ ││ │ │ ││ │ │ │ │ 5 │ 3 │ 9 ││ 2 │ 6 │ 8 ││ 4 │ 7 │ 1 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 8 │ 7 │ 1 ││ 3 │ 4 │ 5 ││ 2 │ 6 │ 9 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 6 │ 4 │ 2 ││ 9 │ 1 │ 7 ││ 5 │ 3 │ 8 │ │ │ │ ││ │ │ ││ │ │ │ └───────┴───────┴───────┘└───────┴───────┴───────┘└───────┴───────┴───────┘ ┌───────┬───────┬───────┐┌───────┬───────┬───────┐┌───────┬───────┬───────┐ │ │ │ ││ │ │ ││ │ │ │ │ 7 │ 6 │ 5 ││ 8 │ 9 │ 4 ││ 1 │ 2 │ 3 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 2 │ 1 │ 4 ││ 6 │ 5 │ 3 ││ 9 │ 8 │ 7 │ │ │ │ ││ │ │ ││ │ │ │ ├───────┼───────┼───────┤├───────┼───────┼───────┤├───────┼───────┼───────┤ │ │ │ ││ │ │ ││ │ │ │ │ 3 │ 9 │ 8 ││ 7 │ 2 │ 1 ││ 6 │ 5 │ 4 │ │ │ │ ││ │ │ ││ │ │ │ └───────┴───────┴───────┘└───────┴───────┴───────┘└───────┴───────┴───────┘ $SUDOKU is starting prune pass # 4 sudoku puzzle solved.
REXX Version 1 Help
The following text file is the documentation (HELp) for the $SUDOKU.REX program.
Note that the $SUDOKU# ($SUDOKU#.REX) isn't included here because of the size of the program.
The $SUDOKU command will display a sudoku puzzle, cells/rows/columns of which may be specified. A sudoku puzzle is a grid of nine 3x3 cells (for a total of 9x9 cells) that can contain the digits 1──►9. The object is to fill in the puzzle so that every row, column, and 3x3 box has every (unique) digit. To show several supplied sudoku puzzles, the $SUDOKU# program can be used to display over 12,600 different puzzles. To see that help, issue: $H $SUDOKU# ╔══════════════════════════════════════════════════════════════════════════════╗ ║ {CLearscneen | NOCLearscreen} ║ ║ {HIGHLightsingles | NOHIGHLightsingles} ║ ║ {PUZZle .d..dd..d.......d..dddd.ddd...ddd.dddd....} ║ ║ {COLumn n .d..dd..d.} ║ ║ {ROW n ...d..d.dd} ║ ║ $SUDOKU {CELL rc d} ║ ║ {PRUNEEXCLusives} {PRUNELINEs} ║ ║ ? {PRUNEMATches} {PRUNEONLYs} {PRUNESINGLes} ║ ║ ?AUTHOR {PRUNEALL} ║ ║ ?FLOW {SHORTgrid} ║ ║ ?SAMPLES {SHOWCELL rc,xy,ab,...} ║ ║ {SHOWBOXes bbb} {SHOWCOLs ccc} {SHOWROWs rrr} ║ ║ {SHOWCOMBinations} ║ ║ {SHOWGrid | NOSHOWGrid} ║ ║ {SHOWINFOmation | NOSHOWINFOmation} ║ ║ {SHOWPOSSibles} ║ ║ {SHOWONELINE} ║ ║ {SIMPLE} ║ ║ {tops} ║ ╚══════════════════════════════════════════════════════════════════════════════╝ ───where: ? shows this help file (press ESC to quit when viewing). ?AUTHOR shows the author of this program. ?FLOW shows the external execution flow of this program. ?SAMPLES shows some sample uses (press ESC to quit when viewing). CLearscreen clears the screen before any grid is shown. The default is: CLEARSCREEN NOCLearscreen doen't clear the screen before any grid is show. The default is: CLEARSCREEN HIGHLightsingles highlights all specified digits (if the grid is shown). A highlighted digits is prefixed and suffixed with a minus sign (-), or shown in yellow if running on CMS or with PC/REXX. The default is: NOHIGHLIGHTSINGLES NOHIGHLightsingles doesn't highlight specified digits (if the grid is shown). The default is: NOHIGHLIGHTSINGLES PUZZle .d..dd..d.......d..dddd.ddd...ddd.dddd.... (for example) The character string that follows are the digits to be placed into the puzzle (going from left to right). row by row. Any position that has a period (.) is skipped over. The 10th character would be the start of row 2, the 19th character would be the start of row 3, etc. The character string is considered to "wrap around", row to row. Up to 81 chars may be specified. COL n .d..dd..d. (for example) D is the column to be specified and must be 1 ───► 9. The character string that follows are the digits to be placed in that column (going from top to bottom), and any position that has a period (.) is skipped over. I.E., to set column 9 (the rightmost column) to blank 3 blank blank 4 7 blank 8, the following could be specified: col 9 .3..47.8 (the rest of the column is left blank). Up to 9 digits (or chars) may be specified. Any number of COL keywords may be specified and they may be given in any order. ROW n ...d..d.dd (for example) D is the row to be specified and must be 1 ───► 9. The character string that follows are the digits to be placed in that row (going from left to right), and any position that has a period (.) is skipped over. I.E., to set row 5 (the middle row) to blank blank 6 9 blank 5 blank 2, the following could be specified: row 5 ..69.5.2 (the rest of the row is left blank). Up to nine digits (or chars) may be specified. Any number of ROW keywords may be specified and they may be given in any order. CELL rc d R is the row to be specified and must be 1 ───► 9, C is the col to be specified and must be 1 ───► 9, D is the digit to be placed and must be 1 ───► 9 or "." I.E., to set the 4th cell in the grid (row 1, col 4) to the digit 7, the following could be specified: CELL 14 7 Any number of CELL keywords my be specified and they may be in any order. PRUNEEXCLusives will prune any possible values that are the only value (digit) for a box. If PRUNESINGLE is in effect, than this digit is made into a specified digit (solves that cell). The default is: NOPRUNEEXCLUSIVES PRUNEMATches will prune any possible values that are matched up (two pairs, three triplets, ...) and then removes them from any other possible on the same row and/or column. If PRUNESINGLE is in effect, any possible values that have now become one digit are made into a specified digit. The default is: NOPRUNEMATCHES PRUNEONLYs will prune any possible values that are the only digit in a row or column, and then then removes all other digits in that cell, and if just a single digit remains, makes it a specified digit (solves that cell). The default is: NOPRUNEONLYS PRUNESINGles will prune any possible values that have a single value (one digit) to be as if it were a specified digit. This is the simplest form of pruning. The default is: NOPRUNESINGles PRUNELINEs will prune any possible values that exist in any row or column that can only can exist in a particular row or column in a box. The default is: NOPRUNELINEs PRUNEALL will prune all of the above PRUNExxx. The default is: NOPRUNEALL SHORTgrid shows a shortened versin of the grid. The default is: NOSHORTGRID NOSHORTgrid shows a full versin of the grid. The default is: NOSHORTGRID SHOWBOXes bbb when showing POSSibles, only those boxes (BBB...) specified have their possible digits shown, where B is the box number(s) and must be 1 ───► 9. The boxes are numbered left to right, top to bottom, with the top left-most box is 1, the middle box is 5, and the 1st box in the middle row is box 4, the 1st box on the last row is box 7. The default is: all boxes. SHOWCOLs ccc when showing POSSibles, only those columns (CCC...) specified have their possible digits shown, where C is the column number(s) and must be 1 ───► 9. The columns are numbered left to right. The default is: all columns SHOWROWs ccc when showing POSSibles, only those rows (CCC...) specified have their possible digits shown, where R is the row number(s) and must be 1 ───► 9. The rows are numbered top to bottom. The default is: all rows SHOWCOMBinations shows the number of combinations of all the possible values. The default is: NOSHOWCOMBinations NOSHOWCOMBinations doesn't show the number of combinations of all the possible values. The default is: NOSHOWCOMBinations SHOWGrid shows the sudoku puzzle in a grid after the digits are specified, after computing the possible values (if wanted), after each pruning (if any). The default is: SHOWGrid NOSHOWGrid doesn't show the grid. The default is: SHOWGrid SHOWINFOmation shows various information messages such as screen titles, action being taken, etc. The default is: SHOWINFOrmation NOSHOWINFOmation doesn't show the informational messages. The default is: SHOWINFOrmation SHOWPOSSibles shows what digits are possible for each empty cell. The SHOWGrid option must be ON, and the cells shown are restricted (if given) by SHOWCELL, SHOWCOLs, and SHOWROWs. The default is: NOSHOWPOSSibles SHORTgrid shows a shortened versin of the grid. The default is: NOSHORTGRID NOSHORTgrid shows a full versin of the grid. The default is: NOSHORTGRID SHOWONELINE shows a the puzzle as speiified as line line of: ....dd....d.d.d..d.....d....d.dd...d.....d....d (for example). Up to 81 characters may be shown, and any trailing periods aren't shown. The default is: NOSHOWONELINE +---+ SIMPle uses | | for the boxing characters. The default is: NOSIMPle +---+ ┌───┐ NOSIMPle uses │ │ for the boxing characters. The default is: NOSIMPle └───┘ tops are any or all of the following $T .X=xxx options. ──────────────────────────────────────────────────────────────────────────────── Some (but not all) of the $T options are: (issue $T ? for more help) ──────── ────────────────────────────────────────────────────────────────────── .I=nnn indents the messages nnn spaces, the default is 0. .C=color sets the color of the messages, there is no default. .H=color sets the highlight color of any parenthesized text, there is no default. .F=fff writes the information (in addition to typing it) to the file, fff there is no default. Ω
REXX Version 1 $ERROR.REX
The $ERR.REX (REXX) program is used to issue various formatted error messages from other REXX programs.
The $ERR.REX program makes use of the $T.REX program to issue the error messages in red (if available).
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),
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
The help for the $T REXX program is included here ──► $T.HEL.
The $T REXX program makes use of $ERR REXX program which is used to display error messages (via $T).
The $ERR REXX program is included here ──► $ERR.REX.
The $T REXX program makes use of LINESIZE BIF which returns the terminals width (linesize).
Some REXXes doen't have a LINESIZE BIF, so one is included here ──► LINESIZE.REX.
The $T REXX program makes use of SCRSIZE BIF which returns the terminals width (linesize) and depth.
Some REXXes doen't have a SCRSIZE BIF, so one is included here ──► SCRSIZE.REX.
The $T REXX program makes use of DELAY BIF which delays (sleeps) for a specified amount of seconds.
Some REXXes doen't have a DELAY BIF, so one is included here ──► DELAY.REX.
The $T REXX program makes use of SOUND BIF which produces sounds via the PC speaker.
Some REXXes doen't have a SOUND BIF, so one is included here ──► SOUND.REX.
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
Select When g.0fid='?' Then Do Say 'This program solves any (valid) SUDOKU puzzle' Say 'Specify the name of the file containing the puzzle as argument' Exit End When g.0fid= Then Call exit 'no input specified' When lines(g.0fid)=0 Then Call exit 'specified input does not exist' Otherwise Nop End instr= Do While lines(g.0fid)>0 instr=instr||linein(g.0fid) End Call lineout g.0fid digits='123456789' buffer=translate(instr,digits'000',digits'0.x'||xrange('00'x,'ff'x)) buffer=space(buffer,0) If length(buffer)<>81 Then Call exit 'invalid input from file' g.0fid Call set_geometry
posbit.=copies('0',9) z=posbit.0 d.z=0
Do i=1 To 9 posbit.i=overlay('1',posbit.i,i,1) z=posbit.i d.z=i End
Do r=1 To 9 Do c=1 To 9 Parse Var buffer d +1 buffer matrix.r.c=posbit.d End End
nn=0 Call show_matrix 'input from' g.0fid res=solve() If res Then Do Call dbg 'nn='format(nn,5) 'res='res Call show_matrix 'solution' End Else Say 'impossible' Exit
solve: Procedure Expose g. matrix. posbit. nn box. boxlr. boxlc.
nn=nn+1 Call dbg 'solve nn='format(nn,5) do i = 1 to 9 do j = 1 to 9 if matrix.i.j=posbit.0 Then Leave i End End If i>9 Then Do do i = 1 to 9 do j = 1 to 9 k = pos('1',matrix.i.j) Call dbg 'sudoku', Format(nn,9) Format(i,9) Format(j,9) Format(k,9) matrix.i.j=posbit.0 result_=neg(or(any_col(i),any_row(j),any_box(i,j))) If substr(result_,k,1)=0 Then Return 0 matrix.i.j=posbit.k End End Return 1 End Else Do result_=neg(or(any_col(i),any_row(j),any_box(i,j))) Call dbg 'resulta='result_ k=0; do Until k=0 Call dbg 'resultb='result_ k=pos('1',result_,k+1) Call dbg 'k='Format(k,2)Format(i,2)Format(j,2) if k>0 then Do; matrix.i.j=posbit.k Call dbg 'setting matrix('i','j')->'k res=solve() Call dbg 'A nn='format(nn,5) 'res='res if res then return 1 else Do; matrix.i.j=posbit.0 Call dbg 'setting matrix('i','j')->'0 End; end; end; return 0 end;
set_geometry:
box.= Do j=1 To 9 /* build the box bounds. */ rr=(((j*3)%10)+1)*3-2 /* compute row lower bound. */ cc=(((j-1)//3)+1)*3-2 /* compute col lower bound. */ boxr.j=rr boxc.j=cc Do r=rr To rr+2 /* build boxes with cell #s. */ Do c=cc To cc+2 box.r.c=j End End End /* j */ rowlb.=10 /* row R, low box number=b. */ 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 r=1 To 9 Do c=1 To 9 b=box.r.c /* 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 End
Return
any_col: Procedure Expose matrix.
Parse Arg r res='000000000' Do c=1 To 9 p=pos('1',matrix.r.c) If p>0 Then res=overlay('1',res,p,1) End Return res
any_row: Procedure Expose matrix.
Parse Arg c res='000000000' Do r=1 To 9 p=pos('1',matrix.r.c) If p>0 Then res=overlay('1',res,p,1) End Return res
any_box: Procedure Expose matrix. box. boxlr. boxlc.
Parse Arg r,c b=box.r.c res='000000000' Do r=boxlr.b For 3 Do c=boxlc.b For 3 p=pos('1',matrix.r.c) If p>0 Then res=overlay('1',res,p,1) End End Return res
or: Procedure
res='000000000' Do ia=1 To 3 a=arg(ia) Do p=1 To 9 If substr(a,p,1)=1 Then res=overlay('1',res,p,1) End End Return res
neg: Procedure
Parse Arg s res= Do p=1 To 9 If substr(s,p,1)=1 Then res=res'0' Else res=res'1' End Return res
o: Say arg(1)
Return
show_matrix:
Call o arg(1) Do r=1 To 9 ol= Do c=1 To 9 m=matrix.r.c ol=ol||d.m' ' If c//3=0 Then ol=ol' ' End Call o ol If r//3=0 Then Call o ' ' End Return
dbg:
If debug=1 Then Say arg(1) Return
exit: Say '*ERROR*' arg(1)</lang>
- Output:
input from d:\_sudoku\in\sdk001.in 4 6 0 0 0 1 0 0 0 0 0 2 0 9 6 0 0 0 0 3 0 0 0 0 0 6 8 0 0 0 0 0 0 0 3 7 0 0 0 6 0 7 0 0 0 5 1 0 0 0 0 0 0 0 8 4 0 0 0 0 0 5 0 0 0 0 7 1 0 9 0 0 0 0 0 3 0 0 0 2 4 solution 4 6 5 8 3 1 2 7 9 7 8 2 4 9 6 3 1 5 1 3 9 5 7 2 4 6 8 6 9 4 1 2 5 8 3 7 3 2 8 6 4 7 5 9 1 5 1 7 9 8 3 6 4 2 8 4 1 2 6 9 7 5 3 2 5 3 7 1 4 9 8 6 9 7 6 3 5 8 1 2 4
REXX: Version 3
This is version 1 (thanks) cut to the essentials, restructured, and modified <lang rexx>/* REXX ---------------------------------------------------------------
- program to solve nearly every SUDOKU puzzle
- using a number of strategies learned from REXX version 1
- and one rather efficient algorithm created by me: prunewalt
- see solve: for details
- Tested with Regina and ooRexx
- See version 2 for a program that solves every valid SUDOKU
- --------------------------------------------------------------------*/
Signal on Halt Signal on Novalue Signal on Syntax Parse Arg fid debug Select When fid='?' Then Do Say 'This program solves many (nearly every?) SUDOKU puzzle' Say 'rexx sudoku file [DEBUG]' Say 'Input: file.in' Say 'Debug: file.dbg' Say 'Known: file.sol' Say 'Incomplete solution (if applicable): fileF.in' Say 'Output: on screen' Say 'Adapt subroutine get_input if necessary!' Say 'See version 2 for a brute force program', 'solving EVERY valid SUDOKU' Exit End When fid= Then Do Say 'Input file not specified' Say 'Enter "rexx sudoku ?" for help' Exit End Otherwise Nop End
g.=0 g.0debug=(translate(debug)='DEBUG')
Call get_input fid /* get input and set up file names */ /* Please adapt to your environment */ Numeric Digits 50 /* because of huge # of combinations */
Call set_geometry
Call show_aa 'the puzzle' /* show the grid to screen */ Call build_poss /* build possible values */ g.0todo_init=g.0todo Call show_poss 'puzzle possibles' /* show 1st possibles */
Call solve /* now try to solve it */
If g.0todo=0 Then Do /* no cell left empty */ Call o g.0fid 'puzzle solved.' /* tell it */ Call o left(g.0fid,12) 'puzzle solved.' Call show_aa 'solved' /* show the solution */ End Else Do /* some cells couldn't be filled */ Call show_poss 'failed' /* show the possibilities left */ Call o left(g.0fid,12) 'puzzle failed g.0todo='g.0todo Call show_aa 'failed','.' /* show the partly solved puzzle */ End
Call write_summary
Exit
build_poss: Procedure Expose g. s. aa. poss.,
box. boxr. boxc. boxlr. boxlc.
/*---------------------------------------------------------------------
- aa.r.c contains the known digits
- we determine which digits are possible for empty positions
- and put them into poss.r.c
- --------------------------------------------------------------------*/
all='123456789' Parse Value With dr. dc. db. /* initialize strings built here */ poss.= Do r=1 To 9 Do c=1 To 9 dr.r=dr.r||aa.r.c /* all digits in row r */ End End Do c=1 To 9 Do r=1 To 9 dc.c=dc.c||aa.r.c /* all digits in col c */ End End Do b=1 To 9 Do r=boxlr.b For 3 Do c=boxlc.b For 3 db.b=db.b||aa.r.c /* all digits in box b */ End End End
g.0tot=0 /* total # of possible digits */ g.0todo=0 /* number of cells to be filled */ g.0comb=1 /* # of possible combinations */
Do r=1 To 9 Do c=1 To 9 /* do this for every r.c */ b=box.r.c /* the box this cell is in */ If aa.r.c= Then Do /* cell not yet known */ used=compress(dr.r||dc.c||db.b) /* all digits already used */ poss.r.c=diff(all,used) /* all others are still possible */ g.0todo=g.0todo+1 /* number of cells yet to fill */ g.0tot=g.0tot+length(poss.r.c) g.0comb=g.0comb*length(poss.r.c) End End End If g.0sol<> Then /* if we know the solution */ Call check_all /* check if everything fits */ Return
solve: /*---------------------------------------------------------------------
- Use several algorithms to determine which cell(s) can safely be set
- prunewalt: if a digit occurs just once
- in a row's, col's or box's list of possible digits
- prunesing: if there is only one possible digit in a cell
- pruneexcl ) Algorithms of version 1 only partly understood (by me!)
- prunemats ) but faithfully restructured to avoid many Iterate
- pruneline ) instructions.
- --------------------------------------------------------------------*/
Call build_poss /* re-build the possibles */ Do g.0pass=1 By 1 Until g.0todo=0 Call o g.0fn 'is starting prune pass #' g.0pass found_pass=0
found=prunewalt() /* find any singles ? */ found_pass=found_pass+found If g.0todo=0 Then Leave If found>0 Then Call show_grid 'after prunewalt'
found=prunesing() /* find any singles ? */ found_pass=found_pass+found If g.0todo=0 Then Leave If found>0 Then Call show_grid 'after prunesing'
found=pruneexcl() /* find any excluives ? */ found_pass=found_pass+found If g.0todo=0 Then Leave If found>0 Then Call show_grid 'after pruneexcl'
found=prunemats(2) /* find any matches (len=2) */ found_pass=found_pass+found If g.0todo=0 Then Leave If found>0 Then Call show_grid 'after prunemats'
found=pruneline() /* find 2 or more on a line? */ found_pass=found_pass+found If g.0todo=0 Then Leave If found>0 Then Call show_grid 'after pruneline'
If found_pass>0 Then Do Call o found_pass 'hits in g.0pass' g.0pass If g.0debug Then Call write_summary End Else Do Call o 'Nothing found in g.0pass' g.0pass Leave End End /* prunes */ Return
prunewalt: Call o '>>>>>> prunewalt tot='g.0tot 'todo='g.0todo /*---------------------------------------------------------------------
- find digits that have only one occurrence in a row or column
- row_poss.r digits in row r
- col_poss.c digits in column c
- box_poss.b digits in box b
- --------------------------------------------------------------------*/
foundwalt=0 /* no matches found so far. */ Do Until changed=0 /* keep searching ... */ changed=0 /* changes made in this routine */ row_poss.= /* build str for each row */ col_poss.= /* build str for each column */ box_poss.= /* build str for each box */
Do r=1 To 9 Do c=1 To 9 b=box.r.c If poss.r.c\== Then Do row_poss.r=row_poss.r poss.r.c col_poss.c=col_poss.c poss.r.c box_poss.b=box_poss.b poss.r.c End End End rl= Do r=1 To 9 ol='row'r':' Do d=1 To 9 cnt=count(d,row_poss.r) ol=ol cnt If cnt=1 Then Do rl=rl r dr.r=d End End End cl= Do c=1 To 9 ol='col'c':' Do d=1 To 9 cnt=count(d,col_poss.c) ol=ol cnt If cnt=1 Then Do dc.c=d cl=cl c End End End
bl= Do b=1 To 9 ol='box'||b':' Do d=1 To 9 cnt=count(d,box_poss.b) ol=ol cnt If cnt=1 Then Do z=r'.'c db.z=d bl=bl z End End End
Do While rl<> Parse Var rl r rl Do c=1 To 9 If pos(dr.r,poss.r.c)>0 Then Do Call set_aa r,c,dr.r,'prunewalt new R' changed=changed+1 foundwalt=foundwalt+1 Call build_poss /* re-build the possibles */ End End End Do While cl<> Parse Var cl c cl Do r=1 To 9 If pos(dc.c,poss.r.c)>0 Then Do Call set_aa r,c,dc.c,'prunewalt new C' changed=changed+1 foundwalt=foundwalt+1 Call build_poss /* re-build the possibles */ End End End Do While bl<> Parse Var bl z cb bl Parse Var z rb '.' cb Do r=boxlr.b For 3 Do c=boxlc.b For 3 If r=rb &, c=cb &, pos(db.z,poss.r.c)>0 Then Do Say 'z='r 'c='c 'poss.'r'.'c'='poss.r.c 'db.b='db.b Call set_aa r,c,db.b,'prunewalt new B' changed=changed+1 foundwalt=foundwalt+1 Call build_poss /* re-build the possibles */ End End End End End Call show_poss 'after prunewalt'
If foundwalt>0 Then Call o '>>>>>> prunewalt foundwalt='foundwalt Else Call o '>>>>>> prunewalt found nothing' g.0foundwalt=g.0foundwalt+foundwalt Return foundwalt
prunesing: Call o '>>>>>> prunesing tot='g.0tot 'todo='g.0todo /*---------------------------------------------------------------------
- look if there are cells with a single possible digit and put these
- into the grid. Return the number of changes made.
- --------------------------------------------------------------------*/
foundsing=0 Do r=1 To 9 Do c=1 To 9 If length(poss.r.c)=1 Then Do /* only possible digit */ Call set_aa r,c,poss.r.c,'prunesing' /* put it into the cell */ foundsing=foundsing+1 /* indicate success */ End End End If foundsing>0 Then Do Call build_poss /* re-build the possibles */ Call o '>>>>>> prunesing foundsing='foundsing End Else Call o '>>>>>> prunesing found nothing' g.0foundsing=g.0foundsing+foundsing Return foundsing
pruneexcl: Call o '>>>>>> pruneexcl tot='g.0tot 'todo='g.0todo /*---------------------------------------------------------------------
- --------------------------------------------------------------------*/
foundexcl=0 Do exclusives=1 /* keep building possibles. */ Do r=1 For 9 Do c=1 For 9 z=poss.r.c lz=length(z) /* get length of possible. */ If lz>0 Then Do y= b=box.r.c Do br=boxr.b For 3 Do bc=boxc.b For 3 /* for every cell in box b */ If br'.'bc<>r'.'c Then y=y||aa.br.bc||poss.br.bc End End Do t=1 For lz q=substr(z,t,1) If pos(q,y)==0 Then Do foundexcl=foundexcl+1 If aa.r.c=q Then Call o 'pruneexcl ??? aa.'r'.'c'='q 'already set' Call o 'foundexcl='foundexcl Call set_aa r,c,q,'pruneexcl' /* a singularity, a sol */ Call o 'pruneexcl found the digit' q, 'by exclusiveness at cell' drc(r,c,z) Call build_poss /* re-build the possibles */ Iterate exclusives End End End End End Leave End If foundexcl>0 Then Do Call o '>>>>>> pruneexcl foundexcl='foundexcl End Else Call o '>>>>>> prunesing found nothing' g.0foundexcl=g.0foundexcl+foundexcl Return foundexcl
prunemats: Call o '>>>>>> prunemats tot='g.0tot 'todo='g.0todo /*---------------------------------------------------------------------
- This example illustrates the working of this strategy:
- Column 1 2 3 4 5 6 7 8 9
- Row 7: . . 1369 29 26 29 137 . 136
- remove 29 from drc 7.3=1369 giving drc 7.3=136 (matches 7.4 7.6)
- Row 7: . . 136 29 26 29 137 . 136
- remove 29 from drc 7.5=26 giving drc 7.5=6 (matches 7.4 7.6) HIT
- Row 7: . . 136 29 6 29 137 . 136
- Row 7: . . 139 29 . 29 137 . 13
- remove 29 from drc 7.3=139 giving drc 7.3=13 (matches 7.4 7.6)
- Row 7: . . 13 29 . 29 137 . 13
- remove 13 from drc 7.7=137 giving drc 7.7=7 (matches 7.9 7.3) HIT
- Row 7: . . 13 29 . 29 7 . 13
- Row 7: . . 139 29 . 29 . . 13
- --------------------------------------------------------------------*/
setmats=0 foundmats=0 /* no matches found so far. */ Parse Arg l /* length of match, L=2,pair */ Do matches=1 Do r=1 For 9 Do c=1 For 9 _=length(poss.r.c) /* get length of possible. */ If _=l Then Do qq=poss.r.c m=0 /* count of matches so far. */ mla=r'.'c Do _c=1 For 9 /* a match in same row? */ If _c<>c &, qq==poss.r._c Then Do m=m+1 /* up count if it's a match. */ mla=mla r'.'_c End End If m>0 Then Do Call o 'AAAA mla='mla Call show_poss_r r Do pc=1 For 9 /* remove other possibles. */ old=poss.r.pc /* save the "old" value. */ If old<>qq & old<> Then Do new=diff(old,qq) /* remove mat's digs from X. */ Call o 'AAAA' r'.'pc':'old '-' qq '-->' new If new<>old Then Do If length(new)=1 Then tag='HIT'; Else tag= Call o 'remove' qq 'from' drc(r,pc,old), 'giving' drc(r,pc,new) '(matches' mla')' tag poss.r.pc=new /* store new value into old. */ Call show_poss 'AAAA1' Call show_poss_r r setmats=setmats+1 /* indicate match was found. */ If length(new)==1 Then Do /*reduce if L=1*/ Call set_aa r,pc,new,'prunemats R' /*store single*/ foundmats=foundmats+1 /* indicate match was found*/ Call build_poss /* re-build the possibles */ Call show_poss 'AAAA2' Call show_poss_r r Iterate matches /* start over. */ End End End End End m=0 mlb=r'.'c Do _r=1 For 9 If _r<>r &, qq==poss._r.c Then Do m=m+1 mlb=_r'.'c End End
If m>0 Then Do Call o 'BBBB mlb='mlb Call show_poss_r r Do pr=1 For 9 old=poss.pr.c If old<>qq & old<> Then Do new=diff(old,qq) Call o 'BBBB' pr'.'c':'old '-' qq '-->' new If new<>old Then Do If length(new)=1 Then tag='HIT'; Else tag= Call o 'remove' qq 'from' drc(pr,c,old), 'giving' drc(pr,c,new) '(matches' mlb')' tag poss.pr.c=new Call show_poss_r r Call show_poss 'BBBB1' setmats=setmats+1 If length(new)==1 Then Do foundmats=foundmats+1 Call set_aa pr,c,new,'prunemats C' Call build_poss /* re-build the possibles */ Call show_poss 'BBBB2' Call show_poss_r r Iterate matches End End End End End End End End Leave End
If foundmats>0 Then Do Call o '>>>>>> prunemats foundmats='foundmats End Else Call o '>>>>>> prunesing found nothing' g.0foundmats=g.0foundmats+foundmats Return setmats
pruneline: Call o '>>>>>> pruneline tot='g.0tot 'todo='g.0todo /*---------------------------------------------------------------------
- --------------------------------------------------------------------*/
Call show_poss ' vor pruneline' pruned=0 foundline=0 /* no matches found so far. */ Do Until changes=0 /* terminate if no changes made */ changes=0 /* initialize number of changes */ poss_boxr.= /* build str for each boxrow */ poss_boxc.= /* build str for each boxcol */ Do r=1 To 9 Do c=1 To 9 b=box.r.c If poss.r.c\== Then Do poss_boxr.r.b=strip(poss_boxr.r.b poss.r.c) poss_boxc.c.b=strip(poss_boxc.c.b poss.r.c) End End End Do r=1 To 9 /* search all rows for twins */ Do cb=1 To 7 By 3 /* 3 boxes containing row r */ b=box.r.cb aline=poss_boxr.r.b /* all poss strings: row r box b */ If words(aline)>=2 Then Do /* more than one */ Call o 'aline' r'.'||b'='aline '(cb='cb')' Do k=1 To 9 /* search for each digit. */ If count(k,aline)>=2 Then Do /* more than one occurrence */ Do jr=rowlb.r For 3 /* look at the other 2 rows. */ If jr<>r &, pos(k,poss_boxr.jr.b)>0 Then /* digit k found */ Iterate k /* continue with the next digit */ End Do jb=rowlb.r For 3 /* search boxes of row R for K. */ If jb<>b &, pos(k,poss_boxr.r.jb)>0 Then Do Do kc=1 To 9 /* find which cell K is in. */ If box.r.kc<>b Then Do If poss.r.kc<> &, pos(k,poss.r.kc)>0 Then Do old=drc(r,kc,poss.r.kc) row_a=poss_r(r) poss.r.kc=diff(poss.r.kc,k) /* remove digit k*/ Call o g.0fn 'row' r': removing' k 'from' old, 'resulting in' drc(r,kc,poss.r.kc) row_b=poss_r(r) Call o ' ' row_a Call o '>>' row_b pruned=pruned+1 If length(poss.r.kc)==1 Then Do Call set_aa r,kc,poss.r.kc,'pruneline R' foundline=foundline+1 Call build_poss /* re-build the possibles */ changes=changes+1 End End End End End End End End End End End
Do c=1 To 9 /* search all cols for twins */ Do b=collb.c By 3 For 3 /* for each col, search box. */ aline=poss_boxc.c.b If words(aline)>=2 Then Do Do k=1 To 9 /* search for each digit. */ If count(k,aline)>=2 Then Do Do jc=boxlc.b For 3 /* look at the other 2 cols. */ If jc<>c&pos(k,poss_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 By 3 For 3 /*search boxes col C for K. */ If jb<>b&pos(k,poss_boxc.c.jb)<>0 Then Do Do kr=1 To 9 /* find which cell K is in. */ If box.kr.c<>b Then Do If poss.kr.c>&, pos(k,poss.kr.c)>0 Then Do old=drc(kr,c,poss.kr.c) col_a=poss_c(c) poss.kr.c=diff(poss.kr.c,k) /* remove digit k*/ Call o g.0fn 'col' c': removing' k 'from' old, 'resulting in' drc(kr,c,poss.kr.c) col_b=poss_c(c) Call o ' ' col_a Call o '>>' col_b pruned=pruned+1 If length(poss.kr.c)==1 Then Do Call set_aa kr,c,poss.kr.c,'pruneline C' foundline=foundline+1 Call build_poss /* re-build the possibles */ changes=changes+1 End End End End End End End End End End End End Call show_poss 'nach pruneline' If foundline>0 Then Call o '>>>>>> pruneline new foundline='foundline 'pruned='pruned Else Call o '>>>>>> pruneline new found nothing' 'pruned='pruned g.0foundline=g.0foundline+foundline Return foundline
show_grid: /*---------------------------------------------------------------------
- show what's known so far
- and what's still to be done
- --------------------------------------------------------------------*/
Parse Arg title Call show_aa title Call show_poss title Return
show_aa: Procedure Expose g. aa. s. /*---------------------------------------------------------------------
- Show all cells that are known already
- and determine the number of cells yet to be filled (g.0todo)
- --------------------------------------------------------------------*/
Parse Arg txt blank='.' Select When txt='the puzzle' |, /* initial call */ txt='solved' Then /* final call (success) */ g.0say=1 /* show on screen */ When txt='failed' Then Do /* final call (failure) */ g.0say=1 /* show on screen */ g.0fail=1 /* write to incomplete solution */ End Otherwise g.0say=0 /* don't show on screen */ End Call o txt /* write to dbg/screen/inco */ g.0todo=0 Do r=1 To 9 /* for all rows */ ol= Do c=1 To 9 /* build a line */ If aa.r.c= Then Do g.0todo=g.0todo+1 ol=ol blank End Else ol=ol aa.r.c If c//3=0 Then /* a blank column */ ol=ol' ' End Call o ol If r//3=0 Then /* a blank line */ Call o ' ' End g.0say=0 /* reset the flags */ g.0fail=0 If g.0todo>0 Then Call o right('to be done:',40) g.0todo Else Call o 'all done' Return
show_poss: Procedure Expose poss. g. s. /*---------------------------------------------------------------------
- show all possible digits of the grid
- --------------------------------------------------------------------*/
Parse Arg txt If g.0todo=0 Then Return Call o copies('-',70) 'todo='g.0todo Call o txt Do r=1 To 9 ol=r Do c=1 To 9 ol=ol left(poss.r.c,7) If c//3=0 Then ol=ol '|' End Call o ol If r//3=0 Then Call o ' ' End Call o ' tot='g.0tot 'todo='g.0todo Call o 'combinations:' g.0comb Return
show_poss_r: Procedure Expose g. poss. /*---------------------------------------------------------------------
- show possible digits in row r
'--------------------------------------------------------------------*/
Parse Arg r Call o poss_r(r) Return
poss_r: Procedure Expose g. poss. /*---------------------------------------------------------------------
- compute possible digits in row r
'--------------------------------------------------------------------*/
Parse Arg r ol='Row' r':' Do c=1 To 9 prc=poss.r.c If prc= Then prc='.' ol=ol left(prc,6) End Return ol
show_poss_c: Procedure Expose g. poss. /*---------------------------------------------------------------------
- show possible digits in column c
'--------------------------------------------------------------------*/
Parse Arg c Call o poss_c(c) Return
poss_c: Procedure Expose g. poss. /*---------------------------------------------------------------------
- compute possible digits in column c
'--------------------------------------------------------------------*/
Parse Arg c ol='Col' c':' Do r=1 To 9 prc=poss.r.c If prc= Then prc='.' ol=ol left(prc,6) End Return ol
compress: Procedure /*---------------------------------------------------------------------
- build a string containing the digits found in s
- Example: compress('11 9 33 55') -> '1359'
- --------------------------------------------------------------------*/
Parse Arg s res= Do d=1 To 9 If pos(d,s)>0 Then res=res||d End Return left(res,9)
diff: /*---------------------------------------------------------------------
- build the 'difference' of two strings (same as squish in version 1)
- Return a string of digits contained in arg(1) not existant in arg(2)
- Example: diff('13895','35') -> '189'
- --------------------------------------------------------------------*/
Return space(translate(arg(1),,word(arg(2) ',',1)),0)
check_all: /*---------------------------------------------------------------------
- check the current status against the target (if this is known)
- --------------------------------------------------------------------*/
error=0 Do r=1 To 9 Do c=1 To 9 If aa.r.c=|aa.r.c=s.r.c Then Nop Else Do Call o 'r='r 'c='c 'soll='s.r.c 'ist='aa.r.c error=1 End End End Do r=1 To 9 Do c=1 To 9 Select When poss.r.c= Then Nop When pos(s.r.c,poss.r.c)>0 Then Nop Otherwise Do Call o 'r='r 'c='c aa.r.c 'not in poss:'poss.r.c error=1 End End End End If error Then Call exit 'an error in check_all' Return
o: /*---------------------------------------------------------------------
- write to the debug file (when g.0debug is true)
- and, if applicable, to the screen (when g.0say is true)
- and to the incomplete solution (when g.0fail is true)
- --------------------------------------------------------------------*/
If g.0say Then Say arg(1) If g.0fail Then Call lineout g.0inco,arg(1) If g.0debug Then Call lineout g.0dbg,arg(1) Return
set_aa: Procedure Expose g. aa. poss. box. boxr. boxc. boxlr. boxlc.,
s. sigl
/*---------------------------------------------------------------------
- put a digit into the cell r.c and show the text given
- --------------------------------------------------------------------*/
Parse Arg r,c,d,text from=sigl If s.r.c<>'*' &, d<>s.r.c Then Do call o 'Trying t set aa.'r'.'c 'to' d 'but should be' s.r.c Call o 'from='from Exit End
Call o 'setting aa.'r'.'c' to d='d '('text')' If g.0done.r.c=1 Then Do Call o 'cell' r'.'c'='aa.r.c '>' d '?????' 'called_from='sigl, 'in pass' g.0pass End aa.r.c=d /* put the digit into the cell */ poss.r.c= /* remove cell's possible digits */ g.0done.r.c=1 /* note that cell was set */ Return
count: Procedure /*---------------------------------------------------------------------
- Return the number of occurrences of d in s (all digits)
- Example: count(3,'123 567 399 13') -> 3
- --------------------------------------------------------------------*/
Parse Arg d,s s=translate(s,'*',d) s=translate(s,,'123456789') s=space(s,0) Return length(s)
drc: Procedure /*---------------------------------------------------------------------
- return coordinates and contents of a cell as r.c=string
- --------------------------------------------------------------------*/
Parse Arg r,c,s Return 'drc' r'.'c'='s
set_geometry: /*---------------------------------------------------------------------
- set miscellaneous relations and limits
- --------------------------------------------------------------------*/
box.= Do b=1 For 9 /* build the box bounds. */ rr=(((b*3)%10)+1)*3-2 /* compute row lower bound. */ cc=(((b-1)//3)+1)*3-2 /* compute col lower bound. */ boxr.b=rr boxc.b=cc Do r=rr To rr+2 /* build boxes with cell #s. */ Do c=cc To cc+2 rc=r||c box.b=box.b rc box.r.c=b End End box.b=strip(box.b) End
rowlb.=9 /* row R, low box number=b. */ collb.=9 /* col R, low box number=b. */ boxlr.=9 /* box B, low row number=r. */ boxlc.=9 /* box B, low col number=c. */ Do r=1 To 9 Do c=1 To 9 b=box.r.c /* 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 */ Return
get_input: Procedure Expose g. aa. s. /*---------------------------------------------------------------------
- get the given puzzle
- 9 rows with 9 columns each containing a digit or a place holder (.x0)
- set the miscellaneous file-ids
- and get the known solution (if available) for checking in get_sol
- --------------------------------------------------------------------*/
Parse Arg g.0fid Parse Var g.0fid g.0fn '.' If g.0debug Then Do g.0dbg=g.0fn'.dbg' /* file to contain debug output */ /********************************* Call lineout g.0dbg If lines(g.0dbg)>0 Then /* if the file exists */ 'erase' g.0dbg /* erase it */ *********************************/ End If pos('.',g.0fid)=0 Then g.0fid=g.0fid'.in' digits='123456789' g.0fidx=g.0fid Say 'process file' g.0fidx If lines(g.0fidx)=0 Then Call exit 'Input file does not exist' instr= Do While lines(g.0fidx)>0 instr=instr linein(g.0fidx) End Call lineout g.0fidx instr=translate(instr,digits'000',digits'.x0'||xrange('00'x,'ff'x)) instr=space(instr,0) Select When length(instr)<81 Then Do Say 'instr='instr'<' Call exit 'Incorrect input - not enough data' End When length(instr)>81 Then Do Say 'instr='instr'<' Call exit 'Incorrect input - too much data' End Otherwise Do Call o ' instr='instr'<' instr=translate(instr,' ','0') End End Do r=1 To 9 Do c=1 To 9 Parse Var instr aa.r.c +1 instr End End g.0inco=g.0fn'f.in' /* file to contain failed res */ if lines(g.0inco)>0 Then /* if the file exists */ 'erase' g.0inco /* erase it */ g.0summ='sudoku.summary' /* file to get statistics */ g.0sol= 'sol\'g.0fn'.sol' /* known solution for checking */ If lines(g.0sol)>0 Then /* if that file is found */ Call get_sol /* get its data */ Else Do /* otherwise */ g.0sol= /* don't check */ s.='*' End Say 'Input from ' g.0fidx Say 'Debug output to ' g.0dbg If lines(g.0sol)>0 Then /* if that file is found */ Say 'Given solution from' g.0sol Say 'Statistics to ' g.0summ Say 'Incomplete solution' g.0inco '(if applicable)' Say 'Hit enter to proceed' Return
get_sol: Procedure Expose g. s. /*---------------------------------------------------------------------
- get the known solution
- (9 rows with 9 columns each containing a digit)
- --------------------------------------------------------------------*/
solvstr= If lines(g.0sol)>0 Then Do Do While lines(g.0sol)>0 solvstr=solvstr linein(g.0sol) End Call lineout g.0sol solvstr=space(solvstr,0) Call o 'solution='solvstr Do r=1 To 9 Do c=1 To 9 Parse Var solvstr s.r.c +1 solvstr End End Do r=1 To 9 ol=s.r.1 Do c=2 To 9 ol=ol s.r.c If c//3=0 Then ol=ol' ' End Call o ol If r//3=0 Then Call o ' ' End End Return
exit: Say 'EXIT' arg(1)
Exit
write_summary: Procedure Expose g. /*---------------------------------------------------------------------
- add a line to the statistics
- file init walt sing excl mats line todo pass
- sdk002.in 56 56 0 0 0 0 0 1
- sdk007.in 61 16 0 0 1 5 39 1 <---
- sdk007.in 61 55 0 0 1 5 0 2 solved
- sdk088.in 50 14 2 34 0 0 0 1
- sdk093.in 55 2 2 1 0 0 50 2 <---
- sdk093.in 55 2 2 1 0 0 50 2 <--- no success
- --------------------------------------------------------------------*/
If lines(g.0summ)=0 Then /* write header line */ Call lineout g.0summ,, 'file init walt sing excl mats line todo pass' If g.0todo>0 Then tag='<---' /* mark a failure */ Else tag= /* show # of hits for each strategy */ summline=left(g.0fid,10) right(g.0todo_init,4), right(g.0foundwalt,4), right(g.0foundsing,4), right(g.0foundexcl,4), right(g.0foundline,4), right(g.0foundmats,4), right(g.0todo,4), right(g.0pass,4) tag /* Say summline */ Call lineout g.0summ,summline Call lineout g.0summ /* close the file */ Return
novalue:
Say 'Novalue raised in line' sigl Say sourceline(sigl) Say 'Variable' condition('D') Signal lookaround
syntax:
Say 'Syntax raised in line' sigl Say sourceline(sigl) Say 'rc='rc '('errortext(rc)')'
halt: lookaround:
If fore() Then Do Say 'You can look around now.' Trace ?R Nop End Exit 12</lang>
- Output:
process file sdk087.in Input from sdk087.in Debug output to 0 Given solution from Statistics to sudoku.summary Incomplete solution sdk087f.in (if applicable) Hit enter to proceed the puzzle . . . . . . 3 . . . . . . 7 1 5 . . . . 2 4 . 6 . 1 8 . . . . . 9 . 4 6 . 9 . 6 1 8 . 3 . 6 1 . 7 . . . . 9 4 3 . 8 . 7 6 . . . . 8 1 4 . . . . . . 9 . . . . . . solved 7 4 1 9 8 5 3 6 2 3 8 6 2 7 1 5 9 4 9 5 2 4 3 6 7 1 8 8 2 7 3 5 9 1 4 6 5 9 4 6 1 8 2 3 7 6 1 3 7 2 4 8 5 9 4 3 5 8 9 7 6 2 1 2 6 8 1 4 3 9 7 5 1 7 9 5 6 2 4 8 3