Code: Select all
Main.Routine:
Gosub Init
Gosub Open.Files
Gosub Get.Input
Gosub Close.Files
System
Init:
Return
Open.Files:
Return
Get.Input:
Return
Close.Files:
Return
Code: Select all
' I start with this line x x there are many spaces between the x's.
' That is just to see if spaces are supported anyway.
' Then here comes a program with substitution:
CONST maxLevels = 50: ' 5 or 6 is probably sufficient, but...
DIM i AS INTEGER, j AS INTEGER, k AS INTEGER
DIM x AS INTEGER, y AS INTEGER
DIM p AS INTEGER, q AS INTEGER
DIM opd(9, 9) AS STRING * 1: ' Original Puzzle Definition
DIM cur(9, 9) AS STRING * 1: ' Current contents of cell
DIM sol(9, 9) AS STRING * 1: ' The first solution
DIM SHARED MyErr AS INTEGER
CONST Line1 = "QBasic Mac's SuDoku Cheater"
CONST Line2 = "x = blank cells"
CONST Line3 = "----------------- Puzzle follows ---------"
DIM cLi(9) AS STRING, cLj(9) AS STRING, cLf(9) AS STRING
CLS
GOSUB GetProblem
'MyErr = 0: ON ERROR GOTO GetMyErr
GOSUB ReadProblem
ON ERROR GOTO 0
IF MyErr = 0 THEN
GOSUB AnalyseProblem
GOSUB ProblemOK
END IF
LOCATE 25, 30, 0: PRINT "CHEAT Version 4.0";
WHILE INKEY$ = "": WEND
LOCATE 25, 20: PRINT SPACE$(40); : LOCATE 23, 1
SYSTEM
GetMyErr: MyErr = ERR: RESUME NEXT
AnalyseProblem:
DIM n AS STRING * 1: ' a digit to be inserted into a cell
DIM Flag(9, 9) AS INTEGER: GOSUB FlagVals: 'Identify 3x3 matrices
CONST D = "123456789"
FOR i = 1 TO 9: cLi(i) = D: NEXT i
FOR i = 1 TO 9: cLj(i) = D: NEXT i
FOR i = 1 TO 9: cLf(i) = D: NEXT i
'Now mark "used up values" due to initial problem
FOR x = 1 TO 9: FOR y = 1 TO 9
n = cur(x, y): 'This is the digit already inserted
IF n <> "-" THEN
IF INSTR(D, n) = 0 THEN PRINT ASC(n): STOP
w$ = cLi(x): '------------Check row x
k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
MID$(w$, k, 1) = " ": ' Indicate 'used up'
cLi(x) = w$
w$ = cLj(y): '------------Check row y
k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
MID$(w$, k, 1) = " ": ' Indicate 'used up'
cLj(y) = w$
w$ = cLf(Flag(x, y)): '------------Check 3X3 matrix
k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
MID$(w$, k, 1) = " ": ' Indicate 'used up'
cLf(Flag(x, y)) = w$
END IF
NEXT y: NEXT x
FOR i = 1 TO 9: ' Remove spaces
m$ = cLi(i): GOSUB ZapSpace: cLi(i) = w$
m$ = cLj(i): GOSUB ZapSpace: cLj(i) = w$
m$ = cLf(i): GOSUB ZapSpace: cLf(i) = w$
NEXT i
RETURN
ProblemOK:
SolveMode = 1: GOSUB SolveProblem
FOR i = 1 TO 9: FOR j = 1 TO 9: sol(i, j) = cur(i, j): NEXT j: NEXT i
IF MyErr > 0 THEN
PRINT "Sorry, but your puzzle is invalid."
RETURN
END IF
IF ExceededProgramLimits THEN RETURN
IF BadSolution THEN RETURN
SolveMode = 2: GOSUB SolveProblem
GOSUB PrintSolution
GOSUB WriteSolution
LOCATE , , 1
PRINT "": PRINT "Looking for other solutions...";
FOR HiZ = HiZ TO 1 STEP -1
LoZ = 0: NoZi = 0: NoZj = 0
SolveMode = 3: : GOSUB SolveProblem
IF MyErr > 0 THEN STOP
IF NOT (BadSolution OR MyErr > 0) THEN
PRINT "Found one!": PRINT
FOR i = 1 TO 9: FOR j = 1 TO 9
sol(i, j) = cur(i, j)
NEXT j: NEXT i
GOSUB WriteSolution
RETURN
END IF
NEXT HiZ
PRINT "None Found"
RETURN
GetProblem:
OPEN "cheat.txt" FOR OUTPUT AS #1
PRINT #1, Line1: PRINT #1, Line2: PRINT #1, Line3
PRINT #1, "Leave the first three lines unchanged except"
PRINT #1, "replace x with the character you use for blank cells"
PRINT #1, ""
PRINT #1, "Then replace all these instructions with your puzzle"
PRINT #1, "What you put here will be scanned and everything will"
PRINT #1, "be ignored except digits 1-9 and whatever you are using"
PRINT #1, "for blank cells."
PRINT #1, ""
PRINT #1, "Required: exactly 81 hits which will be assumed to"
PRINT #1, "be your puzzle"
CLOSE
SHELL "notepad cheat.txt"
RETURN
PrintSolution:
CLS
FOR i = 1 TO 9
FOR j = 1 TO 9: LOCATE i * 2, j * 3: PRINT sol(i, j); : NEXT j
NEXT i
LOCATE 7, 30: PRINT "Difficulty Level:"; HiZ
LOCATE 20, 1
PRINT msg$
RETURN
' ================================
ReadProblem:
OPEN "cheat.txt" FOR INPUT AS #1
LINE INPUT #1, l$: IF l$ <> Line1 THEN MyErr = 1: RETURN
LINE INPUT #1, l$
IF LEN(l$) <> LEN(Line2) THEN MyErr = 2: RETURN
DIM legal AS STRING: legal = "123456789"
IF INSTR(legal, LEFT$(l$, 1)) > 0 THEN MyErr = 3: RETURN
legal = legal + LEFT$(l$, 1)
MID$(l$, 1, 1) = LEFT$(Line2, 1)
IF l$ <> Line2 THEN MyErr = 4: RETURN
LINE INPUT #1, l$: IF l$ <> Line3 THEN MyErr = 5: RETURN
DIM c1 AS STRING * 1, c81 AS STRING
DO WHILE NOT EOF(1)
LINE INPUT #1, l$
FOR i = 1 TO LEN(l$)
c1 = MID$(l$, i, 1)
SELECT CASE INSTR(legal, c1)
CASE 0:
CASE 10: c81 = c81 + "-"
CASE ELSE: c81 = c81 + c1
END SELECT
NEXT i
IF LEN(c81) > 81 THEN MyErr = 6: RETURN
LOOP
CLOSE
IF LEN(c81) <> 81 THEN MyErr = 7: RETURN
k = 0
FOR i = 1 TO 9: FOR j = 1 TO 9
k = k + 1
c$ = MID$(c81, k, 1)
IF INSTR("-123456789", c$) = 0 THEN MyErr = 2: RETURN
opd(i, j) = c$
cur(i, j) = c$
NEXT j: NEXT i
CLOSE
RETURN
WriteSolution:
OPEN "cheat.txt" FOR APPEND AS #1
PRINT #1, ""
FOR i = 1 TO 9
FOR j = 1 TO 3: PRINT #1, sol(i, j); : NEXT j: PRINT #1, " ";
FOR j = 4 TO 6: PRINT #1, sol(i, j); : NEXT j: PRINT #1, " ";
FOR j = 7 TO 9: PRINT #1, sol(i, j); : NEXT j: PRINT #1, ""
NEXT i
CLOSE
PRINT "Your file (cheat.txt) has been updated with the solution."
RETURN
' ===================================
SolveProblem:
FOR i = 1 TO 9: FOR j = 1 TO 9: cur(i, j) = opd(i, j): NEXT j: NEXT i
DIM Li(9) AS STRING: FOR i = 1 TO 9: Li(i) = cLi(i): NEXT i
DIM Lj(9) AS STRING: FOR i = 1 TO 9: Lj(i) = cLj(i): NEXT i
DIM Lf(9) AS STRING: FOR i = 1 TO 9: Lf(i) = cLf(i): NEXT i
CONST msg1 = "Puzzle Solved!"
CONST msg2 = "Sorry, your puzzle is unsolvable"
CONST MSG3 = "Puzzle too hard to solve or maybe even unsolvable"
DIM EntriesMade AS INTEGER: ' How many cells were filled in
DIM EntriesLeft AS INTEGER: EntriesLeft = 81: ' Cells unsolved
DIM collectorX(9) AS STRING: ' Collection of all legal characters
DIM collectorY(9) AS STRING: ' that can be entered somewhere in
DIM collectorF(9) AS STRING: ' this row, column, or 3x3 matrix
DIM Counter(9) AS INTEGER
DIM GuessType AS INTEGER: ' 0=none 1=left 2=right
EntriesMade = 0
GuessType = 0: GOSUB TryToSolve: ' Without making any guesses
IF EntriesLeft = 0 THEN msg$ = msg1: RETURN
IF BadSolution THEN msg$ = msg2: RETURN
Level = 0: GOSUB WalkTree: ' OK, make guesses
IF EntriesLeft = 0 THEN msg$ = msg1: RETURN
IF BadSolution THEN
IF ExceededProgramLimits THEN msg$ = MSG3 ELSE msg$ = msg2
RETURN
END IF
STOP: 'I should never get here
RETURN
' ============================================
TryToSolve:
BadSolution = 0
EntriesMade = 0
DO
GOSUB MakeAPass
LOOP WHILE EntriesLeft > 0 AND EntriesMade > 0
RETURN
MakeAPass:
' Every cell has a list of legal values which is 123456789 minus
' the values already entered in other cells in the same row and
' column and 3x3 matrix. The first thing to do is look at every
' cell and see if said list has only one digit. If so, it can
' be entered immediately.
'
' At the same time, the list of legal values for the cell is to
' be appended to a "collector" for the row, column, or 3x3
DO
FOR i = 1 TO 9: collectorX(i) = "": NEXT i
FOR i = 1 TO 9: collectorY(i) = "": NEXT i
FOR i = 1 TO 9: collectorF(i) = "": NEXT i
GOSUB FillEntries
LOOP WHILE EntriesMade > 0
' OK, here we have done all we can. Time to look at each row,
' column, and 3x3 matrix legal value list. For example, look
' at collectorX(3). If it has any digit that occurs only once
' then that digit can be filled in somewhere on row 3, namely
' the first (and therefore only) cell where the digit is legal.
Did1 = 0: GOSUB DoX: IF Did1 THEN RETURN
Did1 = 0: GOSUB DoY: IF Did1 THEN RETURN
Did1 = 0: GOSUB DoF: IF Did1 THEN RETURN
RETURN
DoX: ' #####
FOR x = 1 TO 9
FOR y = 1 TO 9: Counter(y) = 0: NEXT y
c$ = collectorX(x)
FOR y = 1 TO LEN(c$)
k = VAL(MID$(c$, y, 1))
Counter(k) = Counter(k) + 1
NEXT y
FOR y = 1 TO 9
IF Counter(y) = 1 THEN
Did1 = -1
Entries$ = MID$("123456789", y, 1)
p = x: q = y: GOSUB GotUniqueX
END IF
NEXT y
NEXT x
RETURN
DoY: ' #####
FOR y = 1 TO 9
FOR x = 1 TO 9: Counter(x) = 0: NEXT x
c$ = collectorY(y)
FOR x = 1 TO LEN(c$)
k = VAL(MID$(c$, x, 1))
Counter(k) = Counter(k) + 1
NEXT x
FOR x = 1 TO 9
IF Counter(x) = 1 THEN
Did1 = -1
Entries$ = MID$("123456789", x, 1)
p = x: q = y: GOSUB GotUniqueY
END IF
NEXT x
NEXT y
RETURN
DoF: ' #####
FOR x = 1 TO 9
FOR y = 1 TO 9: Counter(y) = 0: NEXT y
c$ = collectorF(f%)
FOR y = 1 TO LEN(c$)
k = VAL(MID$(c$, y, 1))
Counter(k) = Counter(k) + 1
NEXT y
FOR y = 1 TO 9
IF Counter(y) = 1 THEN
Did1 = -1
GOSUB GotUniqueF
END IF
NEXT y
NEXT x
RETURN
GotUniqueX:
FOR q = 1 TO 9
c$ = cur(p, q)
IF c$ = "-" THEN
f% = Flag(p, q)
IF (INSTR(Lj(q), Entries$) > 0) AND (INSTR(Lf(f%), Entries$) > 0) THEN
GOSUB AddEntry
EXIT FOR
END IF
END IF
NEXT q
RETURN
GotUniqueY:
FOR p = 1 TO 9
c$ = cur(p, q)
IF c$ = "-" THEN
f% = Flag(p, q)
IF (INSTR(Li(p), Entries$) > 0) AND (INSTR(Lf(f%), Entries$) > 0) THEN
GOSUB AddEntry
EXIT FOR
END IF
END IF
NEXT p
RETURN
GotUniqueF:
Entries$ = MID$("123456789", y, 1)
f% = x
FOR p = 1 TO 9: FOR q = 1 TO 9
IF cur(p, q) = "-" THEN
IF Flag(p, q) = f% THEN
IF INSTR(Li(p), Entries$) > 0 THEN
IF INSTR(Lj(q), Entries$) > 0 THEN
IF INSTR(Lf(f%), Entries$) > 0 THEN GOSUB AddEntry
END IF
END IF
END IF
END IF
NEXT q: NEXT p
RETURN
FillEntries:
EntriesMade = 0
EntriesLeft = 0
FOR i = 1 TO 9: FOR j = 1 TO 9
IF cur(i, j) = "-" THEN GOSUB GotCandidate
NEXT j: NEXT i
RETURN
GotCandidate:
CCount = CCount + 1
IF CCount > 10000 THEN
PRINT "I give up - Cannot solve!"
PRINT "Press spacebar": WHILE INKEY$ <> " ": WEND
SYSTEM
END IF
Entries$ = "": ' The character(s) that can be entered
f% = Flag(i, j): ' The flag of the cell
FOR x = 1 TO 9
c$ = CHR$(48 + x): 'The character to be entered, if possible
IF INSTR(Li(i), c$) > 0 THEN
IF INSTR(Lj(j), c$) > 0 THEN
IF INSTR(Lf(f%), c$) > 0 THEN Entries$ = Entries$ + c$
END IF
END IF
NEXT x
IF LEN(Entries$) = 0 THEN BadSolution = -1: EntriesLeft = 81: RETURN
' Entries$ is a list of all legal characters for this cell
SELECT CASE SolveMode: 'zzzzzzzzzzzzzzzz
CASE 1:
SELECT CASE GuessType
CASE 0: ' Ignore
CASE 1:
IF LEN(Entries$) = 2 THEN
IF NoZi = i AND NoZj = j THEN
GOSUB NoZ
ELSE
Entries$ = LEFT$(Entries$, 1)
END IF
Remainder$ = RIGHT$(Entries$, 1): GOSUB CollectRemainder
GuessType = 0
END IF
CASE 2:
IF LEN(Entries$) = 2 THEN
IF NoZi = i AND NoZj = j THEN
GOSUB NoZ
ELSE
Entries$ = RIGHT$(Entries$, 1)
END IF
Remainder$ = LEFT$(Entries$, 1): GOSUB CollectRemainder
GuessType = 0
END IF
END SELECT
CASE 2:
SELECT CASE GuessType
CASE 0: ' Ignore
CASE ELSE:
IF LEN(Entries$) = 2 THEN
HiZ = HiZ + 1
IF INSTR(Entries$, sol(i, j)) = 0 THEN STOP: ' bug
Entries$ = sol(i, j)
Remainder$ = RIGHT$(Entries$, 1): GOSUB CollectRemainder
GuessType = 0
END IF
END SELECT
CASE 3:
SELECT CASE GuessType
CASE 0: ' Ignore
CASE 1:
IF LEN(Entries$) = 2 THEN
LoZ = LoZ + 1
IF LoZ < HiZ THEN
IF INSTR(Entries$, sol(i, j)) = 0 THEN STOP: ' bug
Entries$ = sol(i, j)
ELSEIF LoZ = HiZ THEN
NoZi = i: NoZj = j: SolveMode = 1
GOSUB NoZ
ELSE
Entries$ = LEFT$(Entries$, 1)
END IF
Remainder$ = RIGHT$(Entries$, 1): GOSUB CollectRemainder
GuessType = 0
END IF
CASE 2:
IF LEN(Entries$) = 2 THEN
LoZ = LoZ + 1
IF LoZ < HiZ THEN
IF INSTR(Entries$, sol(i, j)) = 0 THEN STOP: ' bug
Entries$ = sol(i, j)
ELSEIF LoZ = HiZ THEN
NoZi = i: NoZj = j: SolveMode = 1
GOSUB NoZ
ELSE
Entries$ = RIGHT$(Entries$, 1)
END IF
Remainder$ = LEFT$(Entries$, 1): GOSUB CollectRemainder
GuessType = 0
END IF
END SELECT
END SELECT
IF LEN(Entries$) = 1 THEN
p = i: q = j: GOSUB AddEntry
ELSE
EntriesLeft = EntriesLeft + 1
Remainder$ = Entries$: GOSUB CollectRemainder
END IF
RETURN
NoZ:
y = INSTR(Entries$, sol(i, j))
IF y = 0 THEN STOP: 'bug
IF y = 1 THEN
Entries$ = RIGHT$(Entries$, 1)
ELSE
Entries$ = LEFT$(Entries$, 1)
END IF
RETURN
CollectRemainder:
collectorX(i) = collectorX(i) + Remainder$
collectorY(j) = collectorY(j) + Remainder$
collectorF(f%) = collectorF(f%) + Remainder$
RETURN
AddEntry:
EntriesMade = EntriesMade + 1
cur(p, q) = Entries$
w$ = Li(p): GOSUB Zapit: Li(p) = w$
w$ = Lj(q): GOSUB Zapit: Lj(q) = w$
w$ = Lf(f%): GOSUB Zapit: Lf(f%) = w$
RETURN
Zapit:
DIM LL AS INTEGER
LL = LEN(w$)
IF LL = 1 THEN w$ = "": RETURN
z = INSTR(w$, Entries$): IF z = 0 THEN STOP: RETURN 'bug
SELECT CASE z
CASE 1: w$ = RIGHT$(w$, LL - 1)
CASE LL: w$ = LEFT$(w$, LL - 1)
CASE ELSE: w$ = LEFT$(w$, z - 1) + RIGHT$(w$, LL - z)
END SELECT
RETURN
ZapSpace:
w$ = ""
FOR j = 1 TO LEN(m$)
IF MID$(m$, j, 1) <> " " THEN w$ = w$ + MID$(m$, j, 1)
NEXT j
RETURN
FlagVals:
DIM flagval AS INTEGER: flagval = 0
FOR i = 1 TO 9 STEP 3
FOR j = 1 TO 9 STEP 3
flagval = flagval + 1
FOR k = 0 TO 2
Flag(i, j + k) = flagval
Flag(i + 1, j + k) = flagval
Flag(i + 2, j + k) = flagval
NEXT k
NEXT j
NEXT i
RETURN
' ==================================
WalkTree:
IF Level = maxLevels THEN
BadSolution = -1: EntriesLeft = 81
ExceededProgramLimits = -1
RETURN
END IF
Level = Level + 1
GOSUB WalkTree2
Level = Level - 1
RETURN
WalkTree2:
GOSUB ProgressSave
GuessType = 1: GOSUB TryToSolve
IF EntriesLeft = 0 THEN RETURN
IF BadSolution THEN
GOSUB ProgressRestore
GuessType = 2: GOSUB TryToSolve
IF EntriesLeft = 0 THEN RETURN
IF BadSolution THEN RETURN
GOSUB WalkTree: RETURN
END IF
GOSUB WalkTree
IF EntriesLeft = 0 THEN RETURN
IF BadSolution THEN
GOSUB ProgressRestore
GuessType = 2: GOSUB TryToSolve
IF EntriesLeft = 0 THEN RETURN
IF BadSolution THEN RETURN
GOSUB WalkTree: RETURN
END IF
STOP: 'I should never get here
RETURN
ProgressSave:
DIM sv(9, 9, 1 TO maxLevels) AS STRING * 1
DIM sLi(9, 1 TO maxLevels) AS STRING
DIM sLj(9, 1 TO maxLevels) AS STRING
DIM sLf(9, 1 TO maxLevels) AS STRING
FOR i = 1 TO 9: FOR j = 1 TO 9
sv(i, j, Level) = cur(i, j)
NEXT j: NEXT i
FOR i = 1 TO 9: sLi(i, Level) = Li(i): NEXT i
FOR i = 1 TO 9: sLj(i, Level) = Lj(i): NEXT i
FOR i = 1 TO 9: sLf(i, Level) = Lf(i): NEXT i
RETURN
ProgressRestore:
FOR i = 1 TO 9: FOR j = 1 TO 9
cur(i, j) = sv(i, j, Level)
NEXT j: NEXT i
FOR i = 1 TO 9: Li(i) = sLi(i, Level): NEXT i
FOR i = 1 TO 9: Lj(i) = sLj(i, Level): NEXT i
FOR i = 1 TO 9: Lf(i) = sLf(i, Level): NEXT i
RETURN