The QBasic / QB64 Discussion Forum      Other Subforums, Links and Downloads
 
 


  << Previous Topic | Next Topic >>Return to Index  

SuDoku Scratch Pad Verison 3.2

June 13 2005 at 9:38 AM
  (Premier Login iorr5t)
Forum Owner

 
For ready-to-run EXE versions of these and other programs, see www.SuDoku.funURL.com

Mac

DECLARE SUB ScratchPad ()
DECLARE FUNCTION SFM$ ()
DECLARE FUNCTION Generate$ (Old$)
DECLARE FUNCTION CAPSLOCK% ()
DECLARE FUNCTION ColorChange% ()
DECLARE FUNCTION SelectedOption$ (v AS STRING)
CLS
CONST Debugging = 0
DIM SHARED MyErr AS INTEGER
DIM SHARED CChange AS INTEGER: 'Color Change Mode
DIM SHARED CMode AS INTEGER: 'Color Change Mode 2
DEFINT C
CALL ScratchPad
STOP: 'Do I ever get here?
CLS
SYSTEM
GetMyErr: MyErr = ERR: RESUME NEXT

FUNCTION CAPSLOCK%
DEF SEG = &H40
p% = PEEK(&H17) AND 64
DEF SEG
IF p% = 64 THEN CAPSLOCK% = -1
END FUNCTION

FUNCTION ColorChange%
IF NOT CChange THEN EXIT FUNCTION
IF NOT CAPSLOCK THEN EXIT FUNCTION
ColorChange = -1
END FUNCTION

FUNCTION Generate$ (Old$)
DIM s(9) AS STRING: GOSUB LoadS
DIM m(9, 9) AS STRING * 1: ' Matrix to be returned
DIM t(9, 9) AS STRING * 1: ' Temporary matrix
DIM rTemp AS SINGLE, r1 AS INTEGER, r2 AS INTEGER
FOR i = 1 TO 9: FOR j = 1 TO 9
  k = k + 1
  m(i, j) = MID$(Old$, k, 1)
NEXT j: NEXT i
FOR Doo = 1 TO 3
GOSUB Scramble1: 'Scramble the numbers
Mode$ = "row": GOSUB Scramble2: 'Scramble rows within 3x3 rule
Mode$ = "col": GOSUB Scramble2: 'Scramble cols within 3x3 rule
Mode$ = "row": GOSUB Scramble3: 'Scramble Superrows
Mode$ = "col": GOSUB Scramble3: 'Scramble cols within 3x3 rule
NEXT Doo
GOSUB Rotate
w$ = ""
FOR i = 1 TO 9: FOR j = 1 TO 9
  w$ = w$ + m(i, j)
NEXT j: NEXT i
Generate$ = w$
EXIT FUNCTION

Rotate:

FOR i = 1 TO 9: FOR j = 1 TO 9: t(i, j) = m(i, j): NEXT j: NEXT i
p = 1: q = 1: rTemp = RND
SELECT CASE RND
CASE IS < .25: GOSUB Rotate1
CASE IS < .5: GOSUB Rotate2
CASE IS < .75: GOSUB Rotate3
CASE ELSE: GOSUB Rotate4
END SELECT
RETURN

Rotate1:
FOR i = 1 TO 9: FOR j = 1 TO 9
  IF rTemp > .5 THEN m(i, j) = t(q, p) ELSE m(i, j) = t(p, q)
  q = q + 1: IF q > 9 THEN p = p + 1: q = 1
NEXT j: NEXT i
RETURN

Rotate2:
FOR i = 9 TO 1 STEP -1: FOR j = 1 TO 9
  IF rTemp > .5 THEN m(i, j) = t(q, p) ELSE m(i, j) = t(p, q)
  q = q + 1: IF q > 9 THEN p = p + 1: q = 1
NEXT j: NEXT i
RETURN

Rotate3:
FOR i = 1 TO 9: FOR j = 9 TO 1 STEP -1
  IF rTemp > .5 THEN m(i, j) = t(q, p) ELSE m(i, j) = t(p, q)
  q = q + 1: IF q > 9 THEN p = p + 1: q = 1
NEXT j: NEXT i
RETURN

Rotate4:
FOR i = 9 TO 1 STEP -1: FOR j = 9 TO 1 STEP -1
  IF rTemp > .5 THEN m(i, j) = t(q, p) ELSE m(i, j) = t(p, q)
  q = q + 1: IF q > 9 THEN p = p + 1: q = 1
NEXT j: NEXT i
RETURN

Scramble1:
FOR i = 1 TO 9: FOR j = 1 TO 9
  v% = VAL(m(i, j))
  IF v% > 0 THEN m(i, j) = RIGHT$(STR$(VAL(s(v%))), 1)
NEXT j: NEXT i
RETURN

Scramble2:
FOR i = 0 TO 6 STEP 3
  GOSUB GetRnds
  FOR j = 1 TO 9
    IF Mode$ = "row" THEN
      SWAP m(i + r1, j), m(i + r2, j)
    ELSE
      SWAP m(j, i + r1), m(j, i + r2)
    END IF
  NEXT j
NEXT i
RETURN

Scramble3:
GOSUB GetRnds
r1 = (r1 - 1) * 3: r2 = (r2 - 1) * 3
FOR i = 1 TO 3
  FOR j = 1 TO 9
    IF Mode$ = "row" THEN
      SWAP m(i + r1, j), m(i + r2, j)
    ELSE
      SWAP m(j, i + r1), m(j, i + r2)
    END IF
  NEXT j
NEXT i
RETURN

GetRnds:
r1 = 1 + INT(RND * 3)
DO: r2 = 1 + INT(RND * 3): LOOP WHILE r1 = r2
RETURN

LoadS:
FOR i = 1 TO 9: s(i) = RIGHT$(STR$(i), 1): NEXT i
DO
  FOR i = 1 TO 9
    rTemp = INT(1 + (RND * 9))
    SWAP s(i), s(rTemp)
  NEXT i
  cnt = 0
  FOR i = 1 TO 9
    IF VAL(s(i)) = i THEN cnt = cnt + 1
  NEXT i
LOOP WHILE cnt > 2
RETURN

END FUNCTION

DEFSNG C
SUB ScratchPad
CONST fleB = "SSP.Bic": 'Boss-is-coming
CONST fleX = "SSP.Ccx": 'Color changes requested
CONST fleC = "SSP.Ccp": 'Color changes in progress
CONST fleS = "SSP.SvC": ' Saved Colora

CONST H = "0123456789abcdef"

MyErr = 0: ON ERROR GOTO GetMyErr
OPEN fleX FOR INPUT AS #1: CLOSE
ON ERROR GOTO 0
IF MyErr = 0 THEN KILL fleX: GOTO Display

MyErr = 0: ON ERROR GOTO GetMyErr
OPEN fleC FOR INPUT AS #1: CLOSE
ON ERROR GOTO 0
IF MyErr = 0 THEN
  CMode = 1
ELSE
  CMode = 0
  IF NOT Debugging THEN SHELL "mode con cols=40"
  WIDTH 40
END IF
DEFINT C: DIM c(100, 2): 'color c(Cxxxx,1),c(Cxxxx,2)
GOSUB SetColors

DIM aU AS STRING * 2: aU = CHR$(0) + "H": 'arrow keys
DIM aD AS STRING * 2: aD = CHR$(0) + "P"
DIM aR AS STRING * 2: aR = CHR$(0) + "M"
DIM aL AS STRING * 2: aL = CHR$(0) + "K"
DIM i AS INTEGER, j AS INTEGER, k AS INTEGER
DIM V8nX AS INTEGER, V8nY AS INTEGER
DIM opd(9, 9) AS STRING * 1: ' Original Puzzle Digits
DIM cur(9, 9) AS STRING * 1: ' Current contents of cell
DIM Solution(9, 9) AS STRING * 1
FOR i = 1 TO 9: FOR j = 1 TO 9: cur(i, j) = "-": NEXT j: NEXT i
DIM Flag(9, 9) AS INTEGER: GOSUB FlagVals2: 'Identify 3x3 matrices

DIM save(1 TO 3) AS INTEGER

DIM pMode AS INTEGER
CONST Enter = 11
CONST Solve = 12
pMode = Enter

DIM Map(i, j, 2) AS INTEGER: GOSUB LoadMap

DIM Show AS STRING * 9
V8nX = 1: V8nY = 1
IF CMode = 1 THEN GOSUB Display ELSE GOSUB Welcome

' =================== Main Loop =====================
GOSUB DisplayMatrix
DO
  IF CMode = 2 THEN CMode = 1
  GOSUB GetGuess
  GOSUB DisplayMatrix
  DIM Finished AS INTEGER: Finished = -1
  IF LEFT$(Show, 1) = " " THEN
    FOR i = 1 TO 9: FOR j = 1 TO 9
      IF cur(i, j) = "-" THEN Finished = 0: EXIT FOR
    NEXT j: NEXT i
  ELSE
    Finished = 0
  END IF
  IF Finished THEN
    IF KnowsIt THEN
      KnowsIt = 0
      LOCATE 23, 1: PRINT "Finished";
    ELSE
      KnowsIt = -1
      CLS
      PRINT "Completed puzzle!"
      PRINT
      IF Goofs = 0 THEN
        PRINT "Congratulations"
      ELSE
        PRINT "But you goofed"; Goofs; "times :-("
      END IF
      PRINT
      PRINT "Press spacebar to confirm"
      NeedSpace = -1
    END IF
  END IF
LOOP

' =================== Subroutines  =====================

LoadMap:
FOR i = 1 TO 3: FOR j = 1 TO 9: Map(i, j, 1) = (2 * i) + 0: NEXT j: NEXT i
FOR i = 4 TO 6: FOR j = 1 TO 9: Map(i, j, 1) = (2 * i) + 1: NEXT j: NEXT i
FOR i = 7 TO 9: FOR j = 1 TO 9: Map(i, j, 1) = (2 * i) + 2: NEXT j: NEXT i
FOR j = 1 TO 3: FOR i = 1 TO 9: Map(i, j, 2) = (3 * j) + 0: NEXT i: NEXT j
FOR j = 4 TO 6: FOR i = 1 TO 9: Map(i, j, 2) = (3 * j) + 2: NEXT i: NEXT j
FOR j = 7 TO 9: FOR i = 1 TO 9: Map(i, j, 2) = (3 * j) + 4: NEXT i: NEXT j
RETURN

GetGuess:
DO:
  IF CapsLockOld <> CAPSLOCK THEN
    CapsLockOld = NOT CapsLockOld
    GOSUB DisplayMatrix
  END IF
  zK$ = UCASE$(INKEY$)
LOOP WHILE zK$ = ""
IF NeedSpace THEN
  NeedSpace = 0
  WHILE zK$ <> " ": zK$ = INKEY$: WEND
END IF
IF zK$ = "?" THEN STOP
SELECT CASE zK$
CASE CHR$(27):
  IF CMode > 0 THEN CMode = 2
  GOSUB Escape
  RETURN
CASE "F": GOSUB SetFreeGuess
CASE "B": GOTO BossIsComing
CASE aU:
  IF ColorChange THEN
    IF V8cX > 1 THEN V8cX = V8cX - 1
  ELSE
    IF V8nX > 1 THEN V8nX = V8nX - 1
  END IF
CASE aD:
  IF ColorChange THEN
    IF V8cX < 9 THEN V8cX = V8cX + 1
  ELSE
    IF V8nX < 9 THEN V8nX = V8nX + 1
  END IF
CASE aL:
  IF ColorChange THEN
     IF V8cY > 1 THEN V8cY = V8cY - 1
  ELSE
     IF V8nY > 1 THEN V8nY = V8nY - 1
  END IF
CASE aR:
  IF ColorChange THEN
     IF V8cY < 9 THEN V8cY = V8cY + 1
  ELSE
     IF V8nY < 9 THEN V8nY = V8nY + 1
  END IF
CASE CHR$(9):
  IF ColorChange THEN
    IF V8cY > 6 THEN
       V8cY = 1
       IF V8cX > 6 THEN V8cX = 1 ELSE V8cX = V8cX + 3
    ELSE
       V8cY = V8cY + 3
    END IF
  ELSE
    IF V8nY > 6 THEN
       V8nY = 1
       IF V8nX > 6 THEN V8nX = 1 ELSE V8nX = V8nX + 3
    ELSE
       V8nY = V8nY + 3
    END IF
  END IF
CASE ELSE: GOSUB GotGuess
END SELECT
RETURN

BossIsComing:
OPEN fleB FOR OUTPUT AS #1
GOSUB WriteFile2
GOTO AdiosNow

Escape:
IF ColorChange THEN GOSUB ChangeCell: RETURN
IF CMode = 2 THEN GOSUB Display: RETURN
CLS
COLOR c(CMenu, 1), c(CMenu, 2)
PRINT "Menu:"
PRINT ""
PRINT "   I - Ignore this escape"
w$ = "BI"
IF NOT CChange THEN
  PRINT "   X - Exit/Load/Save"
  w$ = w$ + "X"
END IF
IF pMode = Enter THEN
  PRINT "   S - Solve the puzzle"
  PRINT ""
  PRINT ""
  w$ = w$ + "S"
ELSE
  PRINT : PRINT "More menu: Clear progress, then:": PRINT
  PRINT "   C - Continue solving"
  PRINT "   F - Fix puzzle"
  w$ = w$ + "CF"
END IF
LOCATE , 40, 1
SELECT CASE SelectedOption(w$)
CASE "B": GOTO BossIsComing
CASE "X": GOSUB Welcome
CASE "I": RETURN
CASE "S": GOSUB SolveMode
CASE "C": GOSUB ClearIt
CASE "F": GOSUB ClearIt: pMode = Enter
END SELECT
RETURN

SolveMode:
GOSUB ComputeSolution
IF temp$ = "Puzzle Solved!" THEN pMode = Solve
RETURN

ComputeSolution:
save(1) = pMode: save(2) = V8nX: save(3) = V8nY
OPEN "cheat.sav" FOR OUTPUT AS #1
FOR i = 1 TO 9: FOR j = 1 TO 9
  opd(i, j) = cur(i, j)
NEXT j: NEXT i
GOSUB WriteFile2
temp$ = SFM$ '(Solution-Found Message)
IF temp$ = "Puzzle Solved!" THEN
  OPEN "cheat.sav" FOR INPUT AS #1
  GOSUB ReadFile2
  FOR i = 1 TO 9: FOR j = 1 TO 9
    Solution(i, j) = cur(i, j)
    cur(i, j) = opd(i, j)
  NEXT j: NEXT i
ELSE
  LOCATE 23, 1, 1: PRINT temp$
  PRINT "Press spacebar to acknowledge";
  WHILE INKEY$ <> " ": WEND
  PRINT : CLS
END IF
pMode = save(1): V8nX = save(2): V8nY = save(3)
RETURN

ChangeCell:
IF pMode = Enter THEN
  IF Flag(V8cX, V8cY) = Flag(V8nX, V8nY) THEN
    IF (V8cX = V8nX) AND (V8cY = V8nY) THEN CMod = CYSel ELSE CMod = CNSel
  ELSE
    CMod = CCell
  END IF
ELSE
  IF (V8cX = V8nX) AND (V8cY = V8nY) THEN
    IF cur(V8cX, V8cY) = "-" THEN
      CMod = CSnFr
    ELSE ' We are at a number
      IF opd(V8cX, V8cY) = cur(V8cX, V8cY) THEN CMod = CSyFr ELSE CMod = CSnFr
    END IF
  ELSE
    IF opd(V8cX, V8cY) = cur(V8cX, V8cY) THEN
      IF cur(V8cX, V8cY) = "-" THEN CMod = CCell ELSE CMod = CFroz
    ELSE
      CMod = CCell
    END IF
  END IF
END IF
CChange = 0
DO
  GOSUB DisplayMatrix
  COLOR 7, 0
  U% = 5
  LSET U$ = "": GOSUB PLine
  LSET U$ = "": GOSUB PLine
  LSET U$ = "Enter 2-character color or": GOSUB PLine
  LSET U$ = "just hit Enter to quit ": GOSUB PLine
  LSET U$ = "changing the color.": GOSUB PLine
  LSET U$ = "": GOSUB PLine
  LSET U$ = "": GOSUB PLine
  LOCATE , 40: LINE INPUT "Change to "; ch$
  IF ch$ = "" THEN EXIT DO
  IF LEN(ch$) = 2 THEN
    ch1$ = LCASE$(LEFT$(ch$, 1))
    ch2$ = LCASE$(RIGHT$(ch$, 1))
    IF (INSTR(H, ch1$) > 0) AND (INSTR(H, ch2$) > 0) THEN
      c1% = INSTR(H, ch1$) - 1
      c2% = INSTR(H, ch2$) - 1
    END IF
  END IF
  c(CMod, 1) = c1%: c(CMod, 2) = c2%
LOOP
CChange = -1
RETURN

Display:
COLOR 7, 0: CLS
MyErr = 0: ON ERROR GOTO GetMyErr
OPEN fleC FOR INPUT AS #1: CLOSE
ON ERROR GOTO 0
IF MyErr <> 0 THEN
  PRINT "The is the color-codes window."
  PRINT "Leave this window open. Start SSP in another window"
  PRINT "(You will be in color-change mode)"
  PRINT "When finished, return to this window and press spacebar"
  PRINT
  FOR i = 0 TO 15
    FOR j = 0 TO 15
      COLOR i, j: PRINT MID$(H, i + 1, 1); MID$(H, j + 1, 1);
      COLOR 7, 0: PRINT "  ";
    NEXT j
    PRINT
  NEXT i
  OPEN fleC FOR OUTPUT AS #1: CLOSE
  WHILE INKEY$ <> " ": SLEEP 1: WEND
  ON ERROR GOTO GetMyErr: KILL fleC
  COLOR 7, 0: CLS : SYSTEM
END IF
NoLoop = 0: CChange = O
DO: GOSUB Change1: LOOP UNTIL NoLoop
RETURN

Change1:
CChange2 = 0
COLOR 7, 0: CLS
PRINT "The color-code version of SSP is running"
PRINT "Therefore you get this menu."
PRINT
PRINT "What colors would you like to change?"
PRINT "  1 - Menu"
PRINT "  2 - Background"
PRINT "  3 - Welcome Screen"
PRINT "  4 - Available-digit display"
PRINT "  5 - Cells in the puzzle"
PRINT "  6 - No more changes"
SELECT CASE SelectedOption("123456")
CASE "1":  fixq$ = "Menu":  fixq% = CMenu:  GOSUB FixIt
CASE "2":  fixq$ = "Background":  fixq% = CNone:  GOSUB FixIt
CASE "3":  fixq$ = "Welcome":  fixq% = CWelc:  GOSUB FixIt
CASE "4": fixq$ = " Available-digits": fixq% = CAvai: GOSUB FixIt
CASE "5":
  CChange = -1: CChange2 = -1
  NoLoop = -1
  V8cX = 1: V8cY = 1
CASE "6": GOSUB SaveChanges: NoLoop = -1
END SELECT
RETURN

SaveChanges:
COLOR 7, 0: CLS
LOCATE 5, 1, 1
DO
  LINE INPUT "Want to save changes? (y/n): "; yn$
  IF LEN(yn$) <> 1 THEN yn$ = "n"
  yn$ = LCASE$(yn$)
LOOP WHILE INSTR("yn", yn$) = 0
PRINT
LOCATE , , 0
IF yn$ = "y" THEN
  OPEN fleS FOR OUTPUT AS #1
  FOR i = 1 TO maxColors
    WRITE #1, c(i, 1), c(i, 2)
  NEXT i
  CLOSE
  PRINT "Saved"
ELSE
  PRINT "Changes not saved."
END IF
PRINT
PRINT "Shutdown the color-codes window if finished"
PRINT "making changes."
PRINT
PRINT "Press spacebar acknowledge and exit....";
WHILE INKEY$ = "": WEND
CLS : SYSTEM

FixIt:
COLOR 7, 0: CLS
c1% = c(fixq%, 1)
c2% = c(fixq%, 2)
PRINT "Fixing color for "; fixq$
PRINT "Original color is "; MID$(H, c1% + 1, 1); MID$(H, c2% + 1, 1)
PRINT
MyLine = CSRLIN
DO
  LOCATE MyLine, 1
  COLOR c1%, c2%:
  PRINT SPACE$(9): PRINT " Example ": PRINT SPACE$(9)
  COLOR 7, 0: PRINT
  PRINT "Current Color is "; MID$(H, c1% + 1, 1); MID$(H, c2% + 1, 1)
  PRINT "Enter 2-character change"
  PRINT "(Just press enter when no more changes)"
  PRINT
  PRINT SPACE$(20); : LOCATE , 1
  LINE INPUT "Change to "; ch$
  IF ch$ = "" THEN EXIT DO
  IF LEN(ch$) = 2 THEN
    ch1$ = LEFT$(ch$, 1)
    ch2$ = RIGHT$(ch$, 1)
    IF (INSTR(H, ch1$) > 0) AND (INSTR(H, ch2$) > 0) THEN
      c1% = INSTR(H, ch1$) - 1
      c2% = INSTR(H, ch2$) - 1
    END IF
  END IF
LOOP
c(fixq%, 1) = c1%: c(fixq%, 2) = c2%
RETURN

ClearIt:
FOR i = 1 TO 9: FOR j = 1 TO 9
    cur(i, j) = opd(i, j)
NEXT j: NEXT i
RETURN

GotGuess:
IF pMode = Solve AND opd(V8nX, V8nY) <> "-" THEN GOTO NoGood: 'Can't change
tmp% = INSTR("1234567890- ", zK$)
IF tmp% = 0 THEN GOTO NoGood: ' Illegal character entered
c$ = cur(V8nX, V8nY)
IF c$ = zK$ THEN RETURN: ' This cell already has this character
IF tmp% > 9 THEN cur(V8nX, V8nY) = "-": RETURN: 'Erase character
' Will attempt to insert zk$ at x,y
IF INSTR(Show, zK$) = 0 THEN GOTO NoGood
FOR i = 1 TO 9
  IF cur(i, V8nY) = zK$ THEN GOTO NoGood
NEXT i
FOR i = 1 TO 9
  IF cur(V8nX, i) = zK$ THEN GOTO NoGood
NEXT i
cur(V8nX, V8nY) = zK$
IF pMode = Solve AND zK$ <> Solution(V8nX, V8nY) THEN
  CLS
  IF FreeGuess THEN
    FreeGuess = 0
    LOCATE 10, 35: PRINT "Doesn't work out. Free Guess honored."
  ELSE
    Goofs = Goofs + 1
    LOCATE 10, 35: PRINT "You goofed!"
  END IF
  LOCATE 12, 30: PRINT "Goof count so far --->"; Goofs
  fK$ = ""
  DO
    cct = RND * 15
    VIEW PRINT 1 TO 8: COLOR 1, cct: CLS
    VIEW PRINT 14 TO 25: COLOR 1, cct: CLS
    GOSUB Wait10
  LOOP WHILE fK$ <> "x"
  VIEW PRINT
  CLS
  GOTO NoGood
END IF
RETURN

SetFreeGuess:
FreeGuess = -1
CLS
PRINT "Free Guess...."
GOSUB Wait10
RETURN

Wait10:
zK$ = ""
FOR i = 1 TO 10
  WAIT &H3DA, 8: WAIT &H3DA, 8, 8
  IF INKEY$ <> "" THEN fK$ = "x": EXIT FOR
NEXT i
RETURN

NoGood: SOUND 1700, 1.5: RETURN

DisplayMatrix:
COLOR c(CNone, 1), c(CNone, 2): CLS
LOCATE 1, 1, 0: PRINT " "
IF pMode = Enter THEN
  DIM CurFlag AS INTEGER
  CurFlag = Flag(V8nX, V8nY)
  FOR i = 1 TO 9
    FOR j = 1 TO 9
      LOCATE Map(i, j, 1), Map(i, j, 2): COLOR c(CCell, 1), c(CCell, 2)
      IF Flag(i, j) = CurFlag THEN COLOR c(CNSel, 1), c(CNSel, 2)
      IF i = V8nX THEN IF j = V8nY THEN COLOR c(CYSel, 1), c(CYSel, 2)
      PRINT cur(i, j);
    NEXT j
  NEXT i
ELSE
  FOR i = 1 TO 9
    FOR j = 1 TO 9
      LOCATE Map(i, j, 1), Map(i, j, 2)
      COLOR c(CCell, 1), c(CCell, 2)
      IF opd(i, j) <> "-" THEN COLOR c(CFroz, 1), c(CFroz, 2)
      IF i = V8nX THEN
        IF j = V8nY THEN
          IF opd(i, j) = "-" THEN
            COLOR c(CSnFr, 1), c(CSnFr, 2)
          ELSE
            COLOR c(CSyFr, 1), c(CSyFr, 2)
          END IF
        END IF
      END IF
      PRINT cur(i, j);
    NEXT j
  NEXT i
END IF
w$ = "123456789"
FOR i = 1 TO 9
  tmp% = INSTR(w$, cur(i, V8nY))
  IF tmp% > 0 THEN GOSUB ZapIt2
NEXT i
FOR i = 1 TO 9
  tmp% = INSTR(w$, cur(V8nX, i))
  IF tmp% > 0 THEN GOSUB ZapIt2
NEXT i
t% = Flag(V8nX, V8nY)
FOR i = 1 TO 9: FOR j = 1 TO 9
  IF Flag(i, j) = t% THEN
    tmp% = INSTR(w$, cur(i, j))
    IF tmp% > 0 THEN GOSUB ZapIt2
  END IF
NEXT j: NEXT i
IF w$ = "" AND cur(V8nX, V8nY) = "-" THEN w$ = "Can't win"
LSET Show = w$
IF pMode = Solve THEN
  IF opd(V8nX, V8nY) <> "-" THEN LSET Show = "(frozen)"
END IF
COLOR c(CAvai, 1), c(CAvai, 2)
LOCATE 23, 1, 0: PRINT Show$;
IF CChange2 THEN
  IF ColorChange THEN COLOR 4, 14: LOCATE Map(V8cX, V8cY, 1), Map(V8cX, V8cY, 2): PRINT "*";
  COLOR 7, 0
  U$ = SPACE$(30): U% = 3
  LSET U$ = "      Color Change Mode": GOSUB PLine
  LSET U$ = "      -----------------": GOSUB PLine
  U% = 5
  IF CAPSLOCK THEN
    LSET U$ = "Use arrow keys to select a": GOSUB PLine
    LSET U$ = "cell to change and then": GOSUB PLine
    LSET U$ = "use ESC to get color-change": GOSUB PLine
    LSET U$ = "prompt.": GOSUB PLine
    LSET U$ = "": GOSUB PLine
    LSET U$ = "Turn CAPS LOCK off to return": GOSUB PLine
    LSET U$ = "to game.": GOSUB PLine
  ELSE
    LSET U$ = "Turn CAPS LOCK on to select": GOSUB PLine
    LSET U$ = "a type of cell to change.": GOSUB PLine
    LSET U$ = "": GOSUB PLine
    LSET U$ = "Use ESC to return to the": GOSUB PLine
    LSET U$ = "color-change menu.": GOSUB PLine
  END IF
END IF
RETURN

PLine:
IF U% = 0 THEN
  STOP
  IF CMode <> 0 THEN CLS
  RETURN
END IF
IF CMode = 0 THEN STOP: LOCATE U%, 1 ELSE LOCATE U%, 40
PRINT U$;
U% = U% + 1
RETURN

ZapIt2:
DIM LL AS INTEGER
LL = LEN(w$)
IF LL = 1 THEN w$ = "": RETURN
SELECT CASE tmp%
CASE 1: w$ = RIGHT$(w$, LL - 1)
CASE LL: w$ = LEFT$(w$, LL - 1)
CASE ELSE: w$ = LEFT$(w$, tmp% - 1) + RIGHT$(w$, LL - tmp%)
END SELECT
RETURN

Welcome:
COLOR c(CWelc, 1), c(CWelc, 2)
CLS
MyErr = 0: ON ERROR GOTO GetMyErr
OPEN fleB FOR INPUT AS #1
ON ERROR GOTO 0
IF MyErr = 0 THEN
  IveBeenWelcomed% = -1
  GOSUB ReadFile2
  IF pMode = Solve THEN GOSUB ComputeSolution
  KILL fleB
  ' Turning on cursor so it will turn off later
  LOCATE 3, 27, 1: PRINT "Resuming Game ...";
  SLEEP 1: zK$ = INKEY$
  RETURN
END IF
IF NOT IveBeenWelcomed% THEN
  IveBeenWelcomed% = -1
  PRINT "       (www.SuDoku.FunURL.com)"
  tk$ = "SuDoku Scratch Pad (SSP) Version 3.2"
  PRINT " "; tk$: PRINT " "; STRING$(LEN(tk$), "-")
  PRINT
  PRINT "You will be in one of two modes:"
  PRINT
  PRINT "If the current 3x3 matrix is colored,"
  PRINT "you can enter a puzzle taken from your"
  PRINT "newspaper or other source such as"
  PRINT "http://www.dailysudoku.co.uk/sudoku/"
  PRINT
  PRINT "If not, you are finished entering the"
  PRINT "puzzle and are trying to solve it."
  PRINT
  PRINT "Press spacebar now to continue"
  WHILE INKEY$ <> " ": WEND
  CLS
END IF
PRINT "Instructions"
PRINT "------------"
PRINT
PRINT "Use arrow-keys, tab and digits 1-9"
PRINT "(Enter 0, -, or space to erase a digit)"
PRINT
PRINT "At any time:"
PRINT "  -  press ESC to get a current menu"
PRINT "  -  press B if Boss is coming"
PRINT
PRINT "Please select one of these options now:"
PRINT
PRINT "   C - Change Color Scheme"
PRINT
PRINT "   P - Proceed to current puzzle"
PRINT
PRINT "   L - Load a saved puzzle"
PRINT "   S - Save the current puzzle"
PRINT
PRINT "   X - Exit program immediately"
SELECT CASE SelectedOption("CPLSX")
CASE "L": GOSUB LoadP: GOTO Welcome
CASE "S": GOSUB SaveP: GOTO Welcome
CASE "X": GOTO AdiosNow
CASE "C":
  CLS
  PRINT "Press spacebar to terminate"
  PRINT "immediately. Then start SSP"
  PRINT "again to get color choices"
  WHILE INKEY$ <> " ": WEND
  CLS
  OPEN "ssp.ccx" FOR OUTPUT AS #1: CLOSE
  SYSTEM
END SELECT
RETURN

AdiosNow:
COLOR 7, 0
CLS
FOR i = 1 TO 10
  WAIT &H3DA, 8: WAIT &H3DA, 8, 8
NEXT i
SYSTEM

LoadP:
CLS
PRINT "Loading a saved puzzle. Please enter": PRINT "its name."
PRINT : PRINT "(Just press Enter if no puzzle)"
DO: GOSUB LoadPsub: LOOP WHILE pname$ <> "": RETURN
LoadPsub:
PRINT
LINE INPUT "Puzzle name: "; pname$
IF pname$ = "" THEN RETURN
IF INSTR(pname$, ".") > 0 THEN PRINT "Omit suffix": RETURN
MyErr = 0: ON ERROR GOTO GetMyErr
OPEN pname$ + ".sav" FOR INPUT AS #1
ON ERROR GOTO 0
IF MyErr > 0 THEN PRINT "Unable to find that file": RETURN
GOSUB ReadFile2
PRINT : PRINT "Puzzle loaded"
GOSUB TestScramble
GOSUB ComputeSolution
RETURN

TestScramble:
PRINT "Press 'N' (Normal) "
PRINT " - to continue with that puzzle"
PRINT "Press 'S' (Scrambled) "
PRINT " - to make the puzzle look different"
pname$ = ""
DO
  DO: zK$ = UCASE$(INKEY$): LOOP WHILE zK$ = ""
LOOP WHILE INSTR("NS", zK$) = 0
IF zK$ = "N" THEN RETURN
RANDOMIZE TIMER: r# = 100000 * RND
Old$ = "": k = 0
FOR i = 1 TO 9: FOR j = 1 TO 9
  Old$ = Old$ + cur(i, j)
NEXT j: NEXT i
xxx = RND(-r#): New$ = Generate(Old$)
FOR i = 1 TO 9: FOR j = 1 TO 9
  k = k + 1
  cur(i, j) = MID$(New$, k, 1)
NEXT j: NEXT i
Old$ = "": k = 0
FOR i = 1 TO 9: FOR j = 1 TO 9
  Old$ = Old$ + opd(i, j)
NEXT j: NEXT i
xxx = RND(-r#): New$ = Generate(Old$)
FOR i = 1 TO 9: FOR j = 1 TO 9
  k = k + 1
  opd(i, j) = MID$(New$, k, 1)
NEXT j: NEXT i
RETURN

SaveP:
CLS
PRINT "Saving the current puzzle...."
PRINT "Please select a name for it.": PRINT
PRINT "(Just press Enter"
PRINT " to abort SAVE)"
DO: GOSUB SavePsub: LOOP WHILE pname$ <> "": RETURN
SavePsub:
PRINT
LINE INPUT "1-8 character name: "; pname$
IF pname$ = "" THEN RETURN
IF LEN(pname$) > 8 THEN PRINT "Too long": RETURN
MyErr = 0: ON ERROR GOTO GetMyErr
OPEN pname$ + ".sav" FOR APPEND AS #1
ON ERROR GOTO 0
IF MyErr > 0 THEN PRINT "Unable to create that file": RETURN
IF LOF(1) > 0 THEN
  LOCATE , , 1
  PRINT "File already exists. Want to overwrite it? (y/n): ";
  DO
    DO: zK$ = UCASE$(INKEY$): LOOP WHILE zK$ = ""
  LOOP WHILE INSTR("YN", zK$) = 0
  IF zK$ = "N" THEN CLOSE : RETURN
  PRINT zK$
  CLOSE #1: OPEN pname$ + ".sav" FOR OUTPUT AS #1
END IF
GOSUB WriteFile2
PRINT : PRINT "File saved - press spacebar to continue"
WHILE INKEY$ <> " ": WEND
pname$ = ""
RETURN

WriteFile2:
WRITE #1, pMode, V8nX, V8nY
k = 0: w$ = ""
FOR i = 1 TO 9: FOR j = 1 TO 9
   k = k + 1
   w$ = w$ + opd(i, j)
NEXT j: NEXT i
WRITE #1, w$
k = 0: w$ = ""
FOR i = 1 TO 9: FOR j = 1 TO 9
   k = k + 1
   w$ = w$ + cur(i, j)
NEXT j: NEXT i
WRITE #1, w$
WRITE #1, Goofs
CLOSE
RETURN

ReadFile2:
INPUT #1, pMode, V8nX, V8nY
IF V8nX = 0 THEN V8nX = 1
IF V8nY = 0 THEN V8nY = 1
INPUT #1, D$
k = 0
FOR i = 1 TO 9: FOR j = 1 TO 9
    k = k + 1
    opd(i, j) = MID$(D$, k, 1)
NEXT j: NEXT i
INPUT #1, D$
k = 0
FOR i = 1 TO 9: FOR j = 1 TO 9
  k = k + 1
  cur(i, j) = MID$(D$, k, 1)
NEXT j: NEXT i
IF NOT EOF(1) THEN INPUT #1, Goofs
CLOSE
RETURN


FlagVals2:
DIM flagval AS INTEGER
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

SetColors:
i = 0
i = i + 1: c(i, 1) = 7: c(i, 2) = 0: CMenu = i' The pop-up Menu
i = i + 1: c(i, 1) = 7: c(i, 2) = 0: CWelc = i' The Welcome screen
i = i + 1: c(i, 1) = 7: c(i, 2) = 0: CNone = i' Space with no cell
i = i + 1: c(i, 1) = 7: c(i, 2) = 0: CCell = i' Default color
i = i + 1: c(i, 1) = 7: c(i, 2) = 0: CAvai = i' Available digits display
' Colors for the "Enter new puzzle" 3x3 matrix view
i = i + 1: c(i, 1) = 15: c(i, 2) = 3: CNSel = i' Cells not selected
i = i + 1: c(i, 1) = 5: c(i, 2) = 15: CYSel = i' The cell now selected
' Colors for the "Solve puzzle" view
i = i + 1: c(i, 1) = 9: c(i, 2) = 15: CSnFr = i' Selected cell, not frozen
i = i + 1: c(i, 1) = 12: c(i, 2) = 8: CSyFr = i' " cell, frozen
i = i + 1: c(i, 1) = 15: c(i, 2) = 0: CFroz = i' Not selected, frozen
maxColors = i
MyErr = 0: ON ERROR GOTO GetMyErr
OPEN fleS FOR INPUT AS #1
IF MyErr > 0 THEN
  ON ERROR GOTO 0
  CLOSE
  RETURN
END IF
CLS
FOR i = 1 TO maxColors
  INPUT #1, c(i, 1), c(i, 2)
NEXT i
ON ERROR GOTO 0
CLOSE
IF MyErr = 0 THEN RETURN
PRINT fleS; " is no good, please erase or fix it"
SYSTEM

END SUB

FUNCTION SelectedOption$ (v AS STRING)
DIM csr AS INTEGER: csr = POS(0)
PRINT ""
LOCATE , csr, 1: PRINT "Option: ";
DO
  DO: zK$ = UCASE$(INKEY$): LOOP WHILE zK$ = ""
LOOP WHILE INSTR(v, zK$) = 0
SelectedOption$ = zK$
END FUNCTION

FUNCTION SFM$
' Solution-Found Message
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, z AS INTEGER
DIM p AS INTEGER, q AS INTEGER
DIM opd(9, 9) AS STRING * 1: ' Original Puzzle Digits
DIM cur(9, 9) AS STRING * 1: ' Current contents of cell
DIM Solution(9, 9) AS STRING * 1: ' Solution to puzzle

MyErr = 0: ON ERROR GOTO GetMyErr
GOSUB ReadProblem
ON ERROR GOTO 0
IF MyErr = 0 THEN
  GOSUB SolveProblem
  IF MyErr = 0 THEN
    IF NOT ExceededProgramLimits THEN GOSUB WriteSolution
  ELSE
    SFM$ = "Sorry, but your puzzle is invalid."
  END IF
END IF
EXIT FUNCTION

' ================================

ReadProblem:
OPEN "cheat.sav" FOR INPUT AS #1
IF MyErr > 0 THEN STOP: 'Bug in program
GOSUB ReadFile1
IF MyErr > 0 THEN PRINT "Sorry, but your saved file, cheat, is corrupt."
RETURN

ReadFile1:
INPUT #1, i, i, i: ' Ignore Mode and cursor location
INPUT #1, zD$
IF LEFT$(zD$, 1) = " " THEN INPUT #1, zD$ ELSE INPUT #1, dummy$
IF LEN(zD$) <> 81 THEN MyErr = 1: RETURN
k = 0
FOR i = 1 TO 9: FOR j = 1 TO 9
    k = k + 1
    c$ = MID$(zD$, k, 1)
    IF INSTR("-123456789", c$) = 0 THEN MyErr = 2: RETURN
    opd(i, j) = c$
    cur(i, j) = c$
NEXT j: NEXT i
IF NOT EOF(1) THEN INPUT #1, Goofs
CLOSE
RETURN

WriteSolution:
OPEN "cheat.sav" FOR OUTPUT AS #1
GOSUB WriteFile1
RETURN

WriteFile1:
WRITE #1, 0, 0, 0: 'Cheat file values
k = 0: w$ = ""
FOR i = 1 TO 9: FOR j = 1 TO 9
   k = k + 1
   w$ = w$ + opd(i, j)
NEXT j: NEXT i
WRITE #1, w$
k = 0: w$ = ""
FOR i = 1 TO 9: FOR j = 1 TO 9
   k = k + 1
   w$ = w$ + cur(i, j)
NEXT j: NEXT i
WRITE #1, w$
WRITE #1, Goofs
CLOSE
RETURN

' ===================================

SolveProblem:
DIM n AS STRING * 1: ' a digit to be inserted into a cell
DIM Flag(9, 9) AS INTEGER: GOSUB FlagVals: 'Identify 3x3 matrices

' Phase I:  Indicate all cells can legally hold any value
CONST D = "123456789": '
DIM Li(9) AS STRING: FOR i = 1 TO 9: Li(i) = D: NEXT i
DIM Lj(9) AS STRING: FOR i = 1 TO 9: Lj(i) = D: NEXT i
DIM Lf(9) AS STRING: FOR i = 1 TO 9: Lf(i) = D: NEXT i

' Phase II: 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$ = Li(x): '------------Check row x
    k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
    MID$(w$, k, 1) = " ": ' Indicate 'used up'
    Li(x) = w$
    w$ = Lj(y): '------------Check row y
    k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
    MID$(w$, k, 1) = " ": ' Indicate 'used up'
    Lj(y) = w$
    w$ = Lf(Flag(x, y)): '------------Check 3X3 matrix
    k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
    MID$(w$, k, 1) = " ": ' Indicate 'used up'
    Lf(Flag(x, y)) = w$
  END IF
NEXT y: NEXT x
FOR i = 1 TO 9: ' Remove spaces
  m$ = Li(i): GOSUB ZapSpace: Li(i) = w$
  m$ = Lj(i): GOSUB ZapSpace: Lj(i) = w$
  m$ = Lf(i): GOSUB ZapSpace: Lf(i) = w$
NEXT i

' Phase III - Solve the puzzle
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
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

EntriesMade = 0
GuessType = 0: GOSUB TryToSolve: ' Without making any guesses
IF EntriesLeft = 0 THEN SFM$ = msg1: RETURN
IF BadSolution THEN MyErr = 1: SFM$ = msg2: RETURN
Level = 0: GOSUB WalkTree: ' OK, make guesses
IF EntriesLeft = 0 THEN SFM$ = msg1: RETURN
IF BadSolution THEN
  IF ExceededProgramLimits THEN SFM$ = MSG3 ELSE SFM$ = msg2
  RETURN
END IF
STOP: 'I should never get here
RETURN

' ============================================

TryToSolve:
BadSolution = 0
EntriesMade = 0
DO
  keep1% = EntriesLeft: keep2% = EntriesMade
  GOSUB MakeAPass
  IF (keep1% = EntriesLeft) AND (keep2% = EntriesMade) THEN
    keep3% = keep3% + 1
    IF keep3% > 10 THEN BadSolution = -1
    EXIT DO
  END IF
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:
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 GuessType
CASE 0: ' Ignore
CASE 1:
  IF LEN(Entries$) = 2 THEN
    Entries$ = LEFT$(Entries$, 1)
    Remainder$ = RIGHT$(Entries$, 1): GOSUB CollectRemainder
    GuessType = 0
  END IF
CASE 2:
  IF LEN(Entries$) = 2 THEN
    Entries$ = RIGHT$(Entries$, 1)
    Remainder$ = LEFT$(Entries$, 1): GOSUB CollectRemainder
    GuessType = 0
  END IF
END SELECT
IF LEN(Entries$) = 1 THEN
   p = i: q = j: GOSUB AddEntry
ELSE
  EntriesLeft = EntriesLeft + 1
  Remainder$ = Entries$: GOSUB CollectRemainder
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
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
  IF Level > HighWater THEN HighWater = Level
  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:
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

END FUNCTION


    
This message has been edited by iorr5t on Aug 27, 2005 5:37 AM
This message has been edited by iorr5t on Jul 13, 2005 4:53 AM


 
 Respond to this message   
AuthorReply

(Premier Login iorr5t)
Forum Owner

SuDoku Cheater Program (Version 3.1)

June 15 2005, 12:24 PM 

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 Digits
DIM cur(9, 9) AS STRING * 1: ' Current contents of cell
DIM SHARED MyErr AS INTEGER

CLS
MyErr = 0: ON ERROR GOTO GetMyErr
GOSUB ReadProblem
ON ERROR GOTO 0
IF MyErr = 0 THEN
  GOSUB SolveProblem
  IF MyErr = 0 THEN
    GOSUB PrintSolution
    IF NOT ExceededProgramLimits THEN GOSUB WriteSolution
  ELSE
    PRINT "Sorry, but your puzzle is invalid."
  END IF
END IF
LOCATE 25, 30, 0: PRINT "CHEAT Version 3.1";
WHILE INKEY$ = "": WEND
LOCATE 25, 20: PRINT SPACE$(40); : LOCATE 23, 1
SYSTEM

PrintSolution:
CLS
FOR i = 1 TO 9
  FOR j = 1 TO 9: LOCATE i * 2, j * 3: PRINT cur(i, j); : NEXT j
NEXT i
LOCATE 7, 30: PRINT "Difficulty Level:"; HighWater
LOCATE 20, 1
PRINT msg$
RETURN

' ================================

GetMyErr: MyErr = ERR: RESUME NEXT

ReadProblem:
OPEN "cheat.sav" FOR INPUT AS #1
IF MyErr > 0 THEN
  PRINT "First use SSP to enter a puzzle"
  PRINT "Then save it as "; CHR$(34); "cheat"; CHR$(34)
  PRINT
  PRINT "When done, envoke this program again"
  RETURN
END IF
GOSUB ReadFile1
IF MyErr > 0 THEN PRINT "Sorry, but your saved file, cheat, is corrupt."
RETURN

ReadFile1:
INPUT #1, i, i, i: ' Ignore Mode and cursor location
INPUT #1, zD$
IF LEFT$(zD$, 1) = " " THEN INPUT #1, zD$
IF LEN(zD$) <> 81 THEN MyErr = 1: RETURN
k = 0
FOR i = 1 TO 9: FOR j = 1 TO 9
    k = k + 1
    c$ = MID$(zD$, 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.sav" FOR OUTPUT AS #1
GOSUB WriteFile1
PRINT "Your saved file, cheat, has been updated as shown above"
RETURN

WriteFile1:
WRITE #1, 2, 1, 1: 'Solve mode, cursor at 1,1
k = 0: w$ = ""
FOR i = 1 TO 9: FOR j = 1 TO 9
   k = k + 1
   w$ = w$ + opd(i, j)
NEXT j: NEXT i
WRITE #1, w$
k = 0: w$ = ""
FOR i = 1 TO 9: FOR j = 1 TO 9
   k = k + 1
   w$ = w$ + cur(i, j)
NEXT j: NEXT i
WRITE #1, w$
CLOSE
RETURN

' ===================================

SolveProblem:
DIM n AS STRING * 1: ' a digit to be inserted into a cell
DIM Flag(9, 9) AS INTEGER: GOSUB FlagVals: 'Identify 3x3 matrices

' Phase I:  Indicate all cells can legally hold any value
CONST D = "123456789": '
DIM Li(9) AS STRING: FOR i = 1 TO 9: Li(i) = D: NEXT i
DIM Lj(9) AS STRING: FOR i = 1 TO 9: Lj(i) = D: NEXT i
DIM Lf(9) AS STRING: FOR i = 1 TO 9: Lf(i) = D: NEXT i

' Phase II: 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$ = Li(x): '------------Check row x
    k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
    MID$(w$, k, 1) = " ": ' Indicate 'used up'
    Li(x) = w$
    w$ = Lj(y): '------------Check row y
    k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
    MID$(w$, k, 1) = " ": ' Indicate 'used up'
    Lj(y) = w$
    w$ = Lf(Flag(x, y)): '------------Check 3X3 matrix
    k = INSTR(w$, n): IF k = 0 THEN MyErr = 1: RETURN
    MID$(w$, k, 1) = " ": ' Indicate 'used up'
    Lf(Flag(x, y)) = w$
  END IF
NEXT y: NEXT x
FOR i = 1 TO 9: ' Remove spaces
  m$ = Li(i): GOSUB ZapSpace: Li(i) = w$
  m$ = Lj(i): GOSUB ZapSpace: Lj(i) = w$
  m$ = Lf(i): GOSUB ZapSpace: Lf(i) = w$
NEXT i

' Phase III - Solve the puzzle
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:
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 GuessType
CASE 0: ' Ignore
CASE 1:
  IF LEN(Entries$) = 2 THEN
    Entries$ = LEFT$(Entries$, 1)
    Remainder$ = RIGHT$(Entries$, 1): GOSUB CollectRemainder
    GuessType = 0
  END IF
CASE 2:
  IF LEN(Entries$) = 2 THEN
    Entries$ = RIGHT$(Entries$, 1)
    Remainder$ = LEFT$(Entries$, 1): GOSUB CollectRemainder
    GuessType = 0
  END IF
END SELECT
IF LEN(Entries$) = 1 THEN
   p = i: q = j: GOSUB AddEntry
ELSE
  EntriesLeft = EntriesLeft + 1
  Remainder$ = Entries$: GOSUB CollectRemainder
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
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
  IF Level > HighWater THEN HighWater = Level
  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


    
This message has been edited by iorr5t on Jun 18, 2005 8:45 AM
This message has been edited by iorr5t on Jun 17, 2005 6:38 AM
This message has been edited by iorr5t on Jun 16, 2005 6:20 AM


 
 Respond to this message   

(Premier Login iorr5t)
Forum Owner

SuDoku Cheater Program (Version 4.1)

July 27 2005, 11:57 AM 

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
ELSE
  PRINT "You didn't exactly follow instructions"
  PRINT : PRINT "Consult the following for details"
  PRINT "http://www.network54.com/Forum/message?forumid=190883&messageid=1122596857"
END IF
LOCATE 25, 30, 0: PRINT "CHEAT Version 4.1";
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


    
This message has been edited by iorr5t on Jul 28, 2005 5:35 PM
This message has been edited by iorr5t on Jul 28, 2005 5:35 PM


 
 Respond to this message   

(Premier Login iorr5t)
Forum Owner

"You didn't exactly follow instructions"

July 28 2005, 5:27 PM 

You got that message and wonder what it means? Here are the instructions which were found in NOTEPAD when you started the program:

=======================================================
QBasic Mac's SuDoku Cheater
x = blank cells
----------------- Puzzle follows ---------
Leave the first three lines unchanged except
replace x with the character you use for blank cells

Then replace all these instructions with your puzzle
What you put here will be scanned and everything will
be ignored except digits 1-9 and whatever you are using
for blank cells.

Required: exactly 81 hits which will be assumed to
be your puzzle
=======================================================
Here is an example of someone following the instructions:

=======================================================
QBasic Mac's SuDoku Cheater
- = blank cells
----------------- Puzzle follows ---------
-5- --- -37
--- 972 -85
--- 8-- ---
13- 2-- 549
-7- 431 ---
--8 --- ---
-6- -1- --4
7-9 --- -68
--- -2- ---
=======================================================

Note we left the first three lines unchanged except we changed
x = blank cells
to
- = blank cells
(since our puzzle uses "-" for blanks.

The following also would have been legal:

=======================================================
QBasic Mac's SuDoku Cheater
* = blank cells
----------------- Puzzle follows ---------

 ====== ======= =======
| *5*  |  ***  |  *37  |
| ***  |  972  |  *85  |
| ***  |  8**  |  ***  |
 ====== ======= =======
| 13*  |  2**  |  549  |
| *7*  |  431  |  ***  |
| **8  |  ***  |  ***  |
 ====== ======= =======
| *6*  |  *1*  |  **4  |
| 7*9  |  ***  |  *68  |
| ***  |  *2*  |  ***  |
 ====== ======= =======

=======================================================

Note that 1) "*" = blanks and 2) all other characters, which were presumably copied from some SuDoku site, are ignored. The only characters honored are *123456789 and there must be exactly 81 of them.

Any deviation from the above is rejected.

Mac


    
This message has been edited by iorr5t on Jul 28, 2005 5:30 PM


 
 Respond to this message   
Current Topic - SuDoku Scratch Pad Verison 3.2
  << Previous Topic | Next Topic >>Return to Index  
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement  

Newbies usually go to www.qbasic.com and click on The QBasic Forum
Forum regulars have their own ways, which include The QBasic Community Forums