The program first reproduces the puzzle
84653574
65547831
57255487
86532544
38148652
53764222
58776213
11376468
Then it shows all the sets of rows and columns which have multiple occurrences of the various digits. The grouping below headed "5 8 --------" indicates that there are 8 rows/columns which contain multiple occurrences of the digit 5. It then lists them, starting with " 1 4 1 6", indicating row 1, col 4 and row 1 col 6 both contain a 5, etc.
1 1 --------
8 1 8 2
2 3 --------
6 6 6 7 6 8
6 6 7 6
5 8 6 8
3 0 --------
4 5 --------
1 2 1 8
4 7 4 8
2 4 5 4
3 6 8 6
1 8 4 8
5 8 --------
1 4 1 6
2 2 2 3
3 1 3 4 3 5
4 3 4 6
3 1 6 1 7 1
2 3 4 3
1 4 3 4
1 6 4 6
6 2 --------
8 5 8 7
7 5 8 5
7 4 --------
3 2 3 8
7 3 7 4
6 3 7 3
7 4 8 4
8 3 --------
5 2 5 5
1 1 4 1
5 2 7 2
9 0 --------
Then the program presents the minimum removal (19) solution, using pcbouhid's rules:
84653 7
65 47831
72 548
6532 4
3 1 8652
53764 2
8 6213
1 37 68
DECLARE SUB retain ()
CLEAR , , 25000
DATA 84653574
DATA 65547831
DATA 57255487
DATA 86532544
DATA 38148652
DATA 53764222
DATA 58776213
DATA 11376468
DIM SHARED bd$(8), bdChk$(8, 8), soFar$(8, 8), minR(8)
DIM SHARED removed, minRemoved, dig, setNo, sCt
DIM SHARED setRow(9, 20, 15), setCol(9, 20, 15)
DIM SHARED ans$(8, 8)
FOR i = 1 TO 8
READ bd$(i)
FOR j = 1 TO 8
PRINT MID$(bd$(i), j, 1);
NEXT
PRINT
COLOR 7
NEXT
FOR d = 1 TO 9
FOR i = 1 TO 8' rows
ctD = 0
FOR j = 1 TO 8
IF VAL(MID$(bd$(i), j, 1)) = d THEN ctD = ctD + 1
NEXT
IF ctD > 1 THEN
setRow(d, 0, 0) = setRow(d, 0, 0) + 1
tblRow = 0
FOR j = 1 TO 8
IF VAL(MID$(bd$(i), j, 1)) = d THEN
tblRow = tblRow + 1
setRow(d, setRow(d, 0, 0), 0) = tblRow
setRow(d, setRow(d, 0, 0), tblRow) = i
setCol(d, setRow(d, 0, 0), tblRow) = j
END IF
NEXT
END IF
NEXT i
NEXT d
FOR d = 1 TO 9
FOR j = 1 TO 8' cols
ctD = 0
FOR i = 1 TO 8
IF VAL(MID$(bd$(i), j, 1)) = d THEN ctD = ctD + 1
NEXT
IF ctD > 1 THEN
setRow(d, 0, 0) = setRow(d, 0, 0) + 1
tblRow = 0
FOR i = 1 TO 8
IF VAL(MID$(bd$(i), j, 1)) = d THEN
tblRow = tblRow + 1
setRow(d, setRow(d, 0, 0), 0) = tblRow
setRow(d, setRow(d, 0, 0), tblRow) = i
setCol(d, setRow(d, 0, 0), tblRow) = j
END IF
NEXT
END IF
NEXT j
NEXT d
FOR d = 1 TO 9
IF 2 = 2 THEN
PRINT
' FOR ix = 1 TO 8
' PRINT bd$(ix)
' NEXT
PRINT d; setRow(d, 0, 0); " --------"
FOR i = 1 TO setRow(d, 0, 0)
max = setRow(d, i, 0)
FOR j = 1 TO max
PRINT setRow(d, i, j); setCol(d, i, j); " ";
NEXT
PRINT
NEXT
' DO: LOOP UNTIL INKEY$ > ""
END IF
NEXT
FOR dig = 1 TO 9
minRemoved = 999: removed = 0
IF setRow(dig, 0, 0) > 0 THEN
setNo = 1
retain
END IF
NEXT
FOR i = 1 TO 8: totR = totR + minR(i): NEXT
PRINT
PRINT totR
FOR i = 1 TO 8
FOR j = 1 TO 8
IF soFar$(i, j) <> "r" THEN
PRINT MID$(bd$(i), j, 1);
ELSE
PRINT " ";
END IF
NEXT
PRINT
NEXT
SUB retain
DIM bdChkSave$(8, 8)
kCt = 0 ' count of keeps
FOR memb = 1 TO setRow(dig, setNo, 0)
IF bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = "k" THEN kCt = kCt + 1
NEXT memb
IF kCt = 0 THEN
FOR memb = 1 TO setRow(dig, setNo, 0)
bdChkSave$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb))
bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = "r"
NEXT memb
GOSUB eval
FOR memb = 1 TO setRow(dig, setNo, 0)
bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = bdChkSave$(setRow(dig, setNo, memb), setCol(dig, setNo, memb))
NEXT memb
END IF
IF kCt < 2 THEN ' if 2 or more, can't do
IF kCt = 1 THEN
FOR memb = 1 TO setRow(dig, setNo, 0)
bdChkSave$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb))
IF bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) <> "k" THEN
bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = "r"
END IF
NEXT memb
GOSUB eval
FOR memb = 1 TO setRow(dig, setNo, 0)
bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = bdChkSave$(setRow(dig, setNo, memb), setCol(dig, setNo, memb))
NEXT memb
ELSE ' kCt = 0
FOR membKeep = 1 TO setRow(dig, setNo, 0)
FOR memb = 1 TO setRow(dig, setNo, 0)
bdChkSave$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb))
NEXT memb
IF bdChk$(setRow(dig, setNo, membKeep), setCol(dig, setNo, membKeep)) <> "r" THEN
bdChk$(setRow(dig, setNo, membKeep), setCol(dig, setNo, membKeep)) = "k"
FOR memb = 1 TO setRow(dig, setNo, 0)
IF memb <> membKeep THEN bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = "r"
NEXT memb
GOSUB eval
FOR memb = 1 TO setRow(dig, setNo, 0)
bdChk$(setRow(dig, setNo, memb), setCol(dig, setNo, memb)) = bdChkSave$(setRow(dig, setNo, memb), setCol(dig, setNo, memb))
NEXT memb
END IF
NEXT membKeep
END IF ' else for kCt=1
END IF ' kCt < 2
EXIT SUB
eval:
IF setNo = setRow(dig, 0, 0) THEN
GOSUB report
ELSE
setNo = setNo + 1
retain
setNo = setNo - 1
END IF
RETURN
report:
removed = 0
c$ = LTRIM$(STR$(dig))
FOR i = 1 TO 8
FOR j = 1 TO 8
IF MID$(bd$(i), j, 1) = c$ THEN
IF bdChk$(i, j) = "r" THEN
removed = removed + 1
END IF
END IF
NEXT
NEXT
IF removed < minRemoved THEN
minRemoved = removed
FOR i = 1 TO 8
FOR j = 1 TO 8
IF MID$(bd$(i), j, 1) = c$ THEN
IF bdChk$(i, j) = "r" THEN soFar$(i, j) = "r": ELSE soFar$(i, j) = ""
END IF
NEXT
NEXT
minR(dig) = minRemoved
END IF
RETURN
END SUB
|
Posted by Charlie
on 2008-08-23 17:11:48 |