Qbasicnews.com
May 19, 2019, 04:39:00 AM *
Welcome, Guest. Please login or register.

Login with username, password and session length
News: Back to Qbasicnews.com | QB Online Help | FAQ | Chat | All Basic Code | QB Knowledge Base
 
   Home   Help Search Login Register  
Pages: [1] 2 3
  Print  
Author Topic: Make a solver for Su Doku in freebasic.  (Read 19993 times)
Agamemnus
x/ \z
*****
Posts: 3491



« on: August 22, 2005, 01:25:09 AM »

I got interested when this puzzle was integrated into a certain game I play(Don't ask, it's addictive then after 2 yrs boring as hell)

Su doku/sudoku is a (Japanese?) numbers game. In the version I played 1 through 9 represent magical runes.

There is a 81x81 2D box. When the puzzle is complete, it must be filled with numbers, 1-9. Each number cannot repeat in 3 different circumstances:

In the same 3x3 grid. There are 9 non-overlapping grids in the box.
In the same column.
In the same row.

The solver should take a set of numbers from a file as input and output a set of numbers to another file, with the option to print results and progress something like this: (0s represent initial blank spaces)

Code:


(input shown)

124000563
050050000
007000090
013800600
000647012
200000357
789000001
000005200
000310000


I have a working version of a puzzle solver that I made that I can upload after the first few posts or in a few days.

The puzzle description can be found all over the net. Furthermore, some newspapers (especially British), have these in their puzzle pages.

Edit:
Yetifoot gets the "prize" for this challenge: a lifetime supply of free qbasicnews posts and recognition on this first thread!
Logged

Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
Mr Match
Ancient Guru
****
Posts: 575



WWW
« Reply #1 on: August 22, 2005, 02:52:12 PM »

Sudoku is Japanese for "single number"

dont ask, i just know.

i play it once and awhile in a local newspaper here in MN, its pretty fun when you have absolutly nothing to do  Shocked

well, i'll give it my best shot if i have some time left in the day  :wink:

Edit: wow i had alot of typos  :lol:
Logged

Itch-Five Design - Your source for free, well designed, web design.
- - - - - - - - - - - - -
Quote from: stylin
I use QB religiously. Too bad I'm an athiest.
Agamemnus
x/ \z
*****
Posts: 3491



« Reply #2 on: August 23, 2005, 01:35:47 AM »

It's kind of difficult... i'll try cleaning up my code a bit later and then I'll submit it.

It takes practically forever for my program to do one with just 1 initial number....
Logged

Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
rdc
Senior Member
**
Posts: 176



WWW
« Reply #3 on: August 23, 2005, 10:57:05 AM »

I think a genetic algorithm would work very well for this problem.
Logged

KiZ
__/--\__
*****
Posts: 2879


WWW
« Reply #4 on: August 23, 2005, 07:01:55 PM »

Quote from: "rdc"
I think a genetic algorithm would work very well for this problem.

Thats just what I was thinking last night. I was brainstorming about using a Genetic Algo to solve it. The main thing is I cant be bothered programing in the tedious ruleset for checking wether the puzzle is legal.
Logged
Agamemnus
x/ \z
*****
Posts: 3491



« Reply #5 on: August 24, 2005, 12:23:57 AM »

A genetic algorithm would be interesting but difficult. I still need to clean up my code. I'll post it tomorrow and then feel free to add suggestions..
Logged

Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
rdc
Senior Member
**
Posts: 176



WWW
« Reply #6 on: August 24, 2005, 10:50:30 AM »

Quote from: "dark_prevail"
Thats just what I was thinking last night. I was brainstorming about using a Genetic Algo to solve it. The main thing is I cant be bothered programing in the tedious ruleset for checking wether the puzzle is legal.


Actually, the rule set would not be all that difficult. You would mainly just have to check a row, column and region and assign a fitness value to each area. The real problem I see is that it may take a long time to arrive at a solution, since a GA starts with a random ruleset. According to the Wikipedia there can be 6,670,903,752,021,072,936,960 valid solutions in a 9x9 grid.

That being said, it might be fun to try it anyway.
Logged

Agamemnus
x/ \z
*****
Posts: 3491



« Reply #7 on: August 24, 2005, 11:14:22 PM »

Dancing links? Nice.

Still can't post my own program.

Got this off of qb45.com:

http://www.qb45.com/index.php?page=downloads&action=comments&id=1392

Code:

DIM gr$(18, 9), rg$(18, 9): SCREEN 7: CLS : FOR a = 1 TO 9: FOR b = 1 TO 9: gr$(a, b) = " ": LINE (((a - 1) * 32), ((b - 1) * 16) + 11)-STEP(32, 16), 8, B
IF a / 3 = INT(a / 3) AND b / 3 = INT(b / 3) THEN LINE (((a - 3) * 32), ((b - 3) * 16) + 11)-STEP(96, 48), 15, B
NEXT b, a: x = 5: y = 5: vv = 1: c = 0: fl = 0: COLOR 10: LOCATE 21, 2: PRINT "CURSORS"; : COLOR 2: PRINT "=move"; : COLOR 10: PRINT " 1-9"; : COLOR 2
PRINT "=number"; : COLOR 10: PRINT " ENTER"; : COLOR 2: PRINT "=solve": COLOR 10: PRINT " SPACE"; : COLOR 2: PRINT "=clear number"; : COLOR 10
PRINT " DELETE"; : COLOR 2: PRINT "=wipe grid": COLOR 1: PRINT " *SuDoKu SoLVeR*  (c)David Hall 2005";
cc: LOCATE (y * 2) + 1, (x * 4) - 1: COLOR 11: i$ = CHR$(2): IF fl = 0 AND gr$(x, y) <> " " THEN i$ = gr$(x, y)
PRINT i$: COLOR 15: i$ = "": c = c + 1: IF c > 2400 THEN c = 0: fl = fl XOR 1
i$ = RIGHT$(INKEY$, 1): IF VAL(i$) > 0 THEN GOSUB hh: IF fl = 0 THEN gr$(x, y) = i$: GOSUB ff: x = x + 1: IF x > 9 THEN x = 1: y = y + 1: IF y > 9 THEN y = 1
IF i$ = " " THEN gr$(x, y) = " ": GOSUB ff: x = x + 1: IF x > 9 THEN x = 1: y = y + 1: IF y > 9 THEN y = 1
IF i$ = CHR$(13) THEN GOSUB ff: GOTO rn
IF i$ = CHR$(75) AND x > 1 THEN GOSUB ff: x = x - 1 ELSE IF i$ = CHR$(77) AND x < 9 THEN GOSUB ff: x = x + 1
IF i$ = CHR$(72) AND y > 1 THEN GOSUB ff: y = y - 1 ELSE IF i$ = CHR$(80) AND y < 9 THEN GOSUB ff: y = y + 1
IF i$ = CHR$(83) THEN RUN ELSE GOTO cc
ff: LOCATE (y * 2) + 1, (x * 4) - 1: PRINT gr$(x, y): RETURN
hh: fl = 0: a = 1: WHILE a < 10: IF gr$(a, y) = i$ OR gr$(x, a) = i$ THEN fl = 1: RETURN
a = a + 1: WEND: a = INT((x - 1) / 3): a = (a * 3) + 1: b = INT((y - 1) / 3): b = (b * 3) + 1
FOR c = a TO a + 2: FOR d = b TO b + 2: IF gr$(c, d) = i$ THEN fl = 1
NEXT d, c: RETURN
rn: COLOR 7: lf = 0: o = 49: a = 1: b = 1: FOR j = 49 TO 57: FOR y = 1 TO 9: FOR x = 1 TO 9: IF j = 49 THEN rg$(x, y) = ""
IF gr$(x, y) <> " " THEN GOTO zz
i$ = CHR$(j): GOSUB hh: IF fl = 0 THEN rg$(x, y) = rg$(x, y) + i$
IF j = 57 AND LEN(rg$(x, y)) = 1 THEN gr$(x, y) = rg$(x, y): GOSUB ff: lf = 1: rg$(x, y) = ""
zz: NEXT x, y, j: IF lf = 1 THEN GOTO rn
pip: i$ = CHR$(o): y = 1: WHILE y < 10: ct = 0: FOR x = 1 TO 9: IF rg$(x, y) = "" THEN GOTO ra
IF INSTR(1, rg$(x, y), i$) > 0 THEN ct = ct + 1: v = x
ra: NEXT x: IF ct = 1 THEN x = v: gr$(x, y) = i$: GOSUB ff: GOTO rn
y = y + 1: WEND: x = 1
WHILE x < 10: tc = 0: FOR y = 1 TO 9: IF rg$(x, y) = "" THEN GOTO ri
IF INSTR(1, rg$(x, y), i$) > 0 THEN tc = tc + 1: v = y
ri: NEXT y: IF tc = 1 THEN y = v: gr$(x, y) = i$: GOSUB ff: GOTO rn
x = x + 1: WEND
WHILE b < 10: ct = 0: FOR c = a TO a + 2: FOR d = b TO b + 2: IF rg$(c, d) = "" THEN GOTO rk
IF INSTR(1, rg$(c, d), i$) > 0 THEN ct = ct + 1: v = c: w = d
rk: NEXT d, c: IF ct = 1 THEN x = v: y = w: gr$(x, y) = i$: GOSUB ff: GOTO rn
a = a + 3: IF a > 7 THEN a = 1: b = b + 3
WEND: o = o + 1: IF o < 58 THEN GOTO pip
IF vv = 1 THEN vv = 2: j = 0: m = 9: GOSUB kl
mf = 0: co = 0: FOR y = 1 TO 9: FOR x = 1 TO 9: i$ = gr$(x, y): IF i$ = " " THEN co = 1: GOTO bl
gr$(x, y) = " ": GOSUB hh: gr$(x, y) = i$: IF fl = 1 OR (gr$(x, y) = " " AND rg$(x, y) = "") THEN mf = 1
bl: NEXT x, y: IF co = 0 AND mf = 0 THEN COLOR 15: FOR y = 1 TO 9: FOR x = 1 TO 9: GOSUB ff: NEXT x, y: END
IF mf = 1 THEN j = 9: m = 0: GOSUB kl
rb: x = INT(RND(1) * 9) + 1: y = INT(RND(1) * 9) + 1: IF LEN(rg$(x, y)) < 2 THEN GOTO rb
gr$(x, y) = MID$(rg$(x, y), INT(RND(1) * LEN(rg$(x, y))) + 1, 1): GOTO rn
kl: FOR y = 1 TO 9: FOR x = 1 TO 9: gr$(x + m, y) = gr$(x + j, y): rg$(x + m, y) = rg$(x + j, y): NEXT x, y: RETURN
Logged

Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
Neo
Na_th_an
*****
Posts: 2150



« Reply #8 on: August 25, 2005, 09:21:06 AM »

Quote from: "Agamemnus"
124000563
050050000
007000090
013800600
000647012
200000357
789000001
000005200
000310000

This example Su Doku you posted is inconsistent because it has two 5's on the 2nd row.

*making solver now*
Logged
Neo
Na_th_an
*****
Posts: 2150



« Reply #9 on: August 25, 2005, 12:53:47 PM »

Here's what I made today:
http://qbnz.com/harsoft/SuDoku.zip

It's in FreeBasic, and can solve Su Doku's. Comes with 3 su doku files too to test.
On my computer (2 GHz) it takes about ~9 ms to solve a Su Doku this way (which is pretty slow, but still, it seems to work).
Logged
rdc
Senior Member
**
Posts: 176



WWW
« Reply #10 on: August 25, 2005, 01:26:20 PM »

Quote from: "Neo"
It's in FreeBasic, and can solve Su Doku's.


Very impressive.
Logged

Agamemnus
x/ \z
*****
Posts: 3491



« Reply #11 on: August 25, 2005, 02:03:16 PM »

This is mine, but it has a slight problem still with rolling back moves.

Instead of numbers it uses letters that stand for runes in this game that I mentioned earlier...
W = water = 1
E = earth = 2
F = fire = 3
A = air = 4
B = body = 5
M = mind = 6
C = chaos = 7
L = law = 8
D = death = 9


Code:

DECLARE FUNCTION round3%(n%)
DECLARE SUB setupASCIIScreen ()
DECLARE SUB refreshASCIIscreen ()
DECLARE SUB inputPuzzlefromfile (n$)
DECLARE SUB outputPuzzletofile (n$)
declare function puzzleiscorrect% ()
declare function puzzleisfull% ()

'variables for the basic game structure
DIM SHARED runepuzzle%(1 TO 9, 1 TO 9)       'x, y. Values range from 1 to 9.
DIM SHARED invalid%(1 to 9, 1 TO 9, 1 TO 9)  'curtype%, x, y. Each value is 0 or 1.

'e.g.: runelocX%(1, 1) = 0: the first rune type is present on the first row.
DIM SHARED runelocX%(1 TO 9, 1 TO 9)     'type, location. Each value is 0 or 1.
DIM SHARED runelocY%(1 TO 9, 1 TO 9)     'type, location. Each value is 0 or 1.
DIM SHARED exists%(1 TO 9)               'row/column (X/Y) location.
DIM SHARED exists3x3%(9, 1 tO 3, 1 TO 3) 'type, X Y location. Each value is 0 or 1.
dim shared curx%, cury%

'variables for game "visuals"
DIM SHARED initialplaces%(1 TO 9, 1 TO 9) 'x, y
dim shared offsetx%, offsety%
dim shared pausetooutput%: pausetooutput% = 1
dim shared showoutput%: showoutput% = 1
dim shared showOutputFrequency%: showOutputFrequency% = 100 'Internal variable.

'extra variables for the decision tree.
dim shared decisionRuneX%(1 to 81)         '1 to 9.
dim shared decisionRuneY%(1 to 81)         '1 to 9.
dim shared decisionRuneType%(1 to 81)      '1 to 9.
dim shared decisionTreeBranch%(1 to 81)    '1 to 81.
dim shared decisionTreeBranchMax%(1 to 81) '1 to 81.
dim shared decisionTreeRune2%(1 to 81)     '1 to 81.
dim shared decisionTreeX%(1 to 81)         '1 to 9.
dim shared decisionTreeY%(1 to 81)         '1 to 9.
dim shared currentStep%: currentStep% = 1  '1 to 81.

'variables for loading and saving.
dim shared puzzleLoadname$
dim shared puzzleSavename$

'This program needs 3 text files to function:
'agasudoku.txt (must be in same location as agasudoku.exe/.bas),
'and input and output files whose names can be specified inside
'agasudoku.txt.

'example agasudoku.txt:

'example testpuzzle.txt: (not case sensitive)
'
'     WF  
' MEF   C
'A   B  L
'E      M
'  F   W  
' L      B
' B  L   F
' C   ABE
'  DW

'testpuzzleoutput.txt can be a blank file.

close
open "agasudoku.txt" FOR INPUT AS #1
line input #1, puzzleLoadname$
line input #1, puzzleSavename$
for i% = 1 to 2
if eof(1) then exit for
line input #1, p1$
p1$ = lcase(p1$)
if p1$ = "pausetooutput" then pausetooutput% = 1 else pausetooutput% = 1
if p1$ = "showoutput" then showoutput% = 1 else showoutput% = 1
next i%
close

'Load in puzzle from a file.
inputpuzzlefromfile puzzleLoadName$

'sets up the initial conditions for the ASCII screen
setupASCIIScreen




redo1: 'main loop
'Refresh the ASCII rune screen

if puzzleiscorrect% = 0 then gosub undostep': goto redo2

redo2: 'sub-loop used to bypass the undostep if necessary (and it will be).

if showoutput% = 1 then
count1% = count1% + 1
if count1% = showOutputFrequency then count1% = 0: RefreshASCIIScreen
end if

curvalidmax% = 1
currentBranch% = 1


'fill in 8/9 horizontal line. (X)
FOR y1% = 1 TO 9
empties% = 0
FOR x1% = 1 TO 9
IF runepuzzle%(x1%, y1%) = 0 THEN empties% = empties% + 1
NEXT x1%

IF empties% = 1 THEN
FOR i% = 1 TO 9: exists%(i%) = 0:NEXT i%
FOR x1% = 1 TO 9
IF runepuzzle%(x1%, y1%) = 0 THEN placeruneatX% = x1%
exists%(runepuzzle%(x1%, y1%)) = 1
NEXT x1%
FOR curtype% = 1 TO 9
IF exists%(curtype%) = 0 THEN exit for
NEXT curtype%
if exists3x3(curtype%, placeruneatX%, y1%) = 0 then
curx% = placeruneatX%: cury% = y1%
decisionTreeBranch%(currentStep%) = 1
gosub rowcolumnmatch: GOTO redo1
end if
END IF
NEXT y1%


'fill in 8/9 vertical line. (Y)
FOR x1% = 1 TO 9
empties% = 0
FOR y1% = 1 TO 9
IF runepuzzle%(x1%, y1%) = 0 THEN empties% = empties% + 1
NEXT y1%

IF empties% = 1 THEN
FOR i% = 1 TO 9: exists%(i%) = 0:NEXT i%
FOR y1% = 1 TO 9
IF runepuzzle%(x1%, y1%) = 0 THEN placeruneatY% = y1%
exists%(runepuzzle%(x1%, y1%)) = 1
NEXT y1%

FOR curtype% = 1 TO 9
IF exists%(curtype%) = 0 THEN exit for
NEXT curtype%
if exists3x3(curtype%, x1%, placeruneatY%) = 0 then
curx% = x1%
cury% = placeruneatY%
decisionTreeBranch%(currentStep%) = 1
gosub rowcolumnmatch: GOTO redo1
end if
END IF
NEXT x1%




'This loop is used to find a place where a rune must be located
'using the rules of Sudoku as a process of elimination.
FOR curtype% = 1 TO 9
'clear the invalid list. make all spaces valid (valid=0, invalid = 1).
'The invalid list shows where the rune CANNOT be placed.
FOR x1% = 1 TO 9: FOR y1% = 1 TO 9: invalid%(curtype%, x1%, y1%) = 0: NEXT y1%, x1%

'Vertical check.
'Cannot place a rune in a column if one already exists there.
FOR x1% = 1 TO 9
IF runelocx%(curtype%, x1%) = 1 THEN
FOR y1% = 1 TO 9
IF runepuzzle%(x1%, y1%) = 0 THEN invalid%(curtype%, x1%, y1%) = 1
NEXT y1%
END IF
NEXT x1%

'Horizontal check.
'Cannot place a rune in a row if one already exists there.
FOR y1% = 1 TO 9
IF runelocy%(curtype%, y1%) = 1 THEN
FOR x1% = 1 TO 9
IF runepuzzle%(x1%, y1%) = 0 THEN invalid%(curtype%, x1%, y1%) = 1
NEXT x1%
END IF
NEXT y1%

'Go through in 3x3 cells and find valid locations.
'If there is only one valid location in a 3x3 square,
'then set its location as the current rune.
'This also happens to find instances of 8/9 cells and fills them.
FOR x1% = 0 TO 6 STEP 3
FOR y1% = 0 TO 6 STEP 3
curvalidmax% = 0

FOR x2% = 1 TO 3
FOR y2% = 1 TO 3
IF runepuzzle%(x1%+x2%, y1%+y2%) = 0 THEN
IF invalid%(curtype%, x1%+x2%, y1%+y2%) = 0 THEN
if exists3x3(curtype%, round3%(x1+x2%), round3%(y1+y2%)) = 0 then
curvalidmax%=curvalidmax%+1
curx% = x1% + x2%
cury% = y1% + y2%
end if
end if
END IF
NEXT y2%, x2%
IF curvalidmax% = 1 THEN
decisionTreeBranchMax%(currentStep%) = 1
gosub rowcolumnmatch: GOTO redo1
END IF
NEXT y1%, x1%

NEXT curtype%

'This is the multi-branch, or multi-option part of the program.
'So far, every decision has been "mechanical" and 100% correct.
'This part guesses where to go starting with the first choice.
'...If that choice doesn't produce a valid answer it tries the next one.
'It is similar to the previous "FOR curtype% = 1 to 9...NEXT curtype%" loop.
FOR curtype% = 1 TO 9
'clear the invalid list. make all spaces valid (valid=0, invalid = 1).
'The invalid list shows where the rune CANNOT be placed.
FOR x1% = 1 TO 9: FOR y1% = 1 TO 9: invalid%(curtype%, x1%, y1%) = 0: NEXT y1%, x1%

'Vertical check.
'Cannot place a rune in a column if one already exists there.
FOR x1% = 1 TO 9
IF runelocx%(curtype%, x1%) = 1 THEN
FOR y1% = 1 TO 9
invalid%(curtype%, x1%, y1%) = 1
NEXT y1%
END IF
NEXT x1%

'Horizontal check.
'Cannot place a rune in a row if one already exists there.
FOR y1% = 1 TO 9
IF runelocy%(curtype%, y1%) = 1 THEN
FOR x1% = 1 TO 9
invalid%(curtype%, x1%, y1%) = 1
NEXT x1%
END IF
NEXT y1%
next curtype%

'Go through in 3x3 cells and find valid locations.
'If there is only one valid location in a 3x3 square,
'then set its location as the current rune.
'This also happens to find instances of 8/9 cells and fills them.
'Find valid locations for all runes in each square first.
FOR x1% = 0 TO 6 STEP 3
FOR y1% = 0 TO 6 STEP 3
curvalidmax% = 0
for curtype% = 1 to 9
FOR x2% = 1 TO 3
FOR y2% = 1 TO 3
IF runepuzzle%(x1%+x2%, y1%+y2%) = 0 THEN
IF invalid%(curtype%, x1%+x2%, y1%+y2%) = 0 THEN
if exists3x3(curtype%, round3%(x1+x2%), round3%(y1+y2%)) = 0 then
curvalidmax%=curvalidmax%+1
decisionTreeX%(curvalidmax%) = x1% + x2%
decisionTreeY%(curvalidmax%) = y1% + y2%
decisionTreeRune2%(curvalidmax%) = curtype%
end if
end if
END IF
NEXT y2%, x2%
next curtype%

IF curvalidmax% >= 1 THEN
currentBranch% = decisionTreeBranch%(currentStep%)
if currentbranch% = 0 then currentbranch% = 1
curtype% = decisionTreeRune2%(currentBranch%)

curx% = decisionTreeX%(currentBranch%)
cury% = decisionTreeY%(currentBranch%)
decisionTreeBranch%(currentStep%) = currentBranch%
decisionTreeBranchMax%(currentStep%) = curvalidmax%
gosub rowcolumnmatch: GOTO redo1
END IF

NEXT y1%, x1%


justadded% = 0
n2%=n2%+1
locate 3,1: PRINT n2%
if puzzleisfull% = 0 then gosub undostep: goto redo2
RefreshASCIIScreen


locate 3,2: PRINT "Solution below. PRESS <ESC> to exit."
system
do:if inkey$ = CHR$(27) THEN EXIT DO
LOOP

SYSTEM

rowcolumnmatch:
exists3x3%(curtype%, round3%(curx%),round3%(cury%)) = exists3x3%(curtype%, round3%(curx%),round3%(cury%)) + 1
runelocx%(curtype%, curx%) = 1
runelocy%(curtype%, cury%) = 1
runepuzzle%(curx%, cury%) = curtype%
decisionRuneX%(currentStep%) = curx%
decisionRuneY%(currentStep%) = cury%
decisionRuneType%(currentStep%) = curtype%
decisionTreeBranch%(currentStep%) = currentBranch%
decisionTreeBranchMax%(currentStep%) = curvalidmax%

currentStep% = currentStep% + 1
justadded% = 1
return

undostep:
if justadded% = 1 then currentStep% = currentStep% - 1:
justadded%  =0
do
curtype% = decisionRuneType%(currentStep%)
curx% = decisionRuneX%(currentStep%)
cury% = decisionRuneY%(currentStep%)
exists3x3%(curtype%, round3%(curx%),round3%(cury%)) = 0
runelocx%(curtype%, curx%) = 0
runelocy%(curtype%, cury%) = 0
runepuzzle%(curx%, cury%) = 0

if decisionTreeBranch%(currentStep%) <> decisionTreeBranchMax%(currentStep%) then exit do
currentStep% = currentStep% - 1
loop

decisionTreeBranch%(currentStep%) = decisionTreeBranch%(currentStep%) + 1
return

FUNCTION round3%(n%)
SELECT CASE n%
CASE 1 TO 3: round3% = 1
CASE 4 TO 6: round3% = 2
CASE 7 TO 9: round3% = 3
END SELECT
END FUNCTION


SUB inputPuzzlefromfile (n$)
'open the rune puzzle info file.
CLOSE
OPEN n$ FOR INPUT AS #1
FOR y1% = 1 TO 9
LINE INPUT #1, st1$
FOR x1% = 1 TO 9
rune1$ = ucase$(MID$(st1$, x1%, 1))
SELECT CASE rune1$
CASE " ": runepuzzle%(x1%, y1%) = 0
CASE "W": runepuzzle%(x1%, y1%) = 1
CASE "E": runepuzzle%(x1%, y1%) = 2
CASE "F": runepuzzle%(x1%, y1%) = 3
CASE "A": runepuzzle%(x1%, y1%) = 4
CASE "B": runepuzzle%(x1%, y1%) = 5
CASE "M": runepuzzle%(x1%, y1%) = 6
CASE "C": runepuzzle%(x1%, y1%) = 7
CASE "L": runepuzzle%(x1%, y1%) = 8
CASE "D": runepuzzle%(x1%, y1%) = 9
END SELECT
curtype% = runepuzzle%(x1%, y1%)
IF curtype% <> 0 THEN
initialplaces%(x1%, y1%) = 1
runelocX%(curtype%, x1%) = 1
runelocY%(curtype%, y1%) = 1
END IF
exists3x3(curtype%, round3(x1%),round3%(y1%)) = 1
NEXT x1%, y1%
CLOSE
END SUB

sub outputPuzzletofile (n$)
OPEN n$ FOR OUTPUT AS #1
FOR y1% = 1 TO 9: st1$ = ""
FOR x1% = 1 TO 9
SELECT CASE runepuzzle%(x1%, y1%)
CASE 0: runename$ = "-"
CASE 1: runename$ = "W"
CASE 2: runename$ = "E"
CASE 3: runename$ = "F"
CASE 4: runename$ = "A"
CASE 5: runename$ = "B"
CASE 6: runename$ = "M"
CASE 7: runename$ = "C"
CASE 8: runename$ = "L"
CASE 9: runename$ = "D"
END SELECT
st1$ = st1$ + runename$
NEXT x%
PRINT #1, st1$
NEXT y%
end sub

'setup of the screen in ASCII format.
SUB setupASCIIScreen ()
CLS
offsetx% = 10
offsety% = 10
COLOR , 15
PRINT STRING$(2600, " ");
FOR i% = 1 TO 9
LOCATE offsety% + i% + 3, offsetx% + 2: PRINT str$(i%)
LOCATE offsety% + i% + 3, offsetx% + 14: PRINT str$(i%)
LOCATE offsety% + 2, offsetx% + i% + 3: PRINT str$(i%)
LOCATE offsety% + 14, offsetx% + i% + 3: PRINT str$(i%)
NEXT i%
locate 1,3: print ""
end sub


'refresh of the screen in ASCII format.
sub refreshASCIIscreen ()
FOR x1% = 1 TO 9
FOR y1% = 1 TO 9
LOCATE offsety% + y1% + 3, offsetx% + x1% + 3
IF x1% = curx% AND y1% = cury% THEN COLOR 2 ELSE IF initialplaces%(x1%,y1%) = 1 THEN COLOR 7 ELSE COLOR 1
SELECT CASE runepuzzle%(x1%, y1%)
CASE 0: runename$ = "-"
CASE 1: runename$ = "W"
CASE 2: runename$ = "E"
CASE 3: runename$ = "F"
CASE 4: runename$ = "A"
CASE 5: runename$ = "B"
CASE 6: runename$ = "M"
CASE 7: runename$ = "C"
CASE 8: runename$ = "L"
CASE 9: runename$ = "D"
END SELECT

PRINT runename$

NEXT y1%
next x1%
if pausetooutput% then sleep
end sub


'verification function.
function puzzleiscorrect% ()
for y1% = 1 to 9
for x1% = 1 to 9
if runepuzzle%(x1%, y1%) <> 0 then
for x2% = 1 to 9
if x2% <> x1% then
if runepuzzle%(x1%, y1%) = runepuzzle%(x2%, y1%) then exit function
end if
next x2%
end if
next x1%
next y1%

for y1% = 1 to 9
for x1% = 1 to 9
if runepuzzle%(x1%, y1%) <> 0 then
for y2% = 1 to 9
if y2% <> y1% then
if runepuzzle%(x1%, y1%) = runepuzzle%(x1%, y2%) then exit function
end if
next y2%
end if
next x1%
next y1%

for runetype% = 1 to 9
for x1% = 1 to 3
for y1% = 1 to 3
if exists3x3%(x1%, y1%, runetype%) > 1 then exit function
next y1%, x1%
next runetype%
puzzleiscorrect% = -1
end function


'"full table?" function.
function puzzleisfull% ()
for x1% = 1 to 9
for y1% = 1 to 9
if runepuzzle%(x1%, y1%) = 0 then exit function
next y1%, x1%
puzzleisfull% = -1
end function
Logged

Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
Anonymous
Guest
« Reply #12 on: August 25, 2005, 04:34:46 PM »

format your code for once in your life !! XD !!
Logged
Agamemnus
x/ \z
*****
Posts: 3491



« Reply #13 on: September 06, 2005, 09:42:31 PM »

Code:


C:\>

C:\> FORMAT

This will erase all data in your hard disk. Proceed? (Y/N)

> Y

Erasing... 1% complete... hit ESC to exit erase procedure.
Erasing...99% complete...hit ESC to exit erase procedure.
Erasing... Well it looks a bit too bloody late now, isn't it?
Logged

Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
yetifoot
Ancient Guru
****
Posts: 575



« Reply #14 on: January 20, 2006, 12:43:39 PM »

This is an(other) updated version.

Code:
' Sudoku Solver (lib) v1.0b by yetifoot
' PUBLIC DOMAIN
' This is setup to run as a regular program, to demonstrate.
' In order to use this in a program, just remove the code afer 'Example Usage',
' then declare the 'board_solve' sub in your code.

Option Explicit

' Needed for memory functions
#include "crt.bi"

' Formulas used when determing board position/row/column
#define GetPos(x,y,b) (x + (y * 9) + (b * 3) + ((b \ 3) * 18))
#define GetCol(x,y,b) (GetPos(x,y,b) mod 9)
#define GetRow(x,y,b) (GetPos(x,y,b) \ 9)

' Enable using True/False
Enum Bool
  False
  True = NOT False
End Enum

' Structure used when determining valid candidates in the board
Type CANDIDATE_TYPE
  x As Integer
  y As Integer
  b As Integer
  num_possible_values As Integer
  possible_values(9) As Integer
End Type

' ---------------------------------------------------------------------------- '
' Functions for checking if a number is in any given row, cell or box

Function InRow(board As uByte ptr, r As Integer, n As Integer) As Integer
  Dim As Integer c
    For c = 0 To 8
      If board[c + (r * 9)] = n Then Return True
    Next c
    Return False
End Function

Function InCol(board As uByte ptr, c As Integer, n As Integer) As Integer
  Dim As Integer r
    For r = 0 To 8
      If board[c + (r * 9)] = n Then Return True
    Next r
    Return False
End Function

Function InBox(board As uByte ptr, b As Integer, n As Integer) As Integer
  Dim As Integer x, y
    For y = 0 To 2
      For x = 0 To 2
        If board[GetPos(x, y, b)] = n Then Return True
      Next x
    Next y
    Return False
End Function

' ---------------------------------------------------------------------------- '
' Functions to check a boards validity, and if its filled

Function IsValid(board As uByte ptr) As Integer
  Dim As Integer r, c, b, i, x, y, p, n
  Dim As Integer numseen(10)
 
  '!!!!!!!!!!!!!!!!!!!!!
  '  NOTE :
  '    Check Rows and Check Cols can be combined
  '    (in inner loop swap r and c, and repeat)
  '!!!!!!!!!!!!!!!!!!!!!
 
    'Check Rows
    For r = 0 To 8
      For i = 0 To 9
        numseen(i) = 0
      Next i
      For c = 0 To 8
        p = c + (r * 9)
        n = board[p]
        numseen(n) += 1
        If (numseen(n) > 1) AND (n <> 0) Then
          Return False
        End If
      Next c
    Next r
   
    'Check Cols
    For c = 0 To 8
      For i = 0 To 9
        numseen(i) = 0
      Next i
      For r = 0 To 8
        p = c + (r * 9)
        n = board[p]
        numseen(n) += 1
        If (numseen(n) > 1) AND (n <> 0) Then        
          Return False
        End If
      Next r      
    Next c
   
    'Check Boxes
    For b = 0 To 8
      For i = 0 To 9
        numseen(i) = 0
      Next i
      For y = 0 To 2
        For x = 0 To 2
          p = GetPos(x, y, b)
          n = board[p]
          numseen(n) += 1
          If (numseen(n) > 1) AND (n <> 0) Then
            Return False      
          End If
        Next x
      Next y
    Next b
    ' If we've got this far, it must be valid
    Return True
End Function

Function IsFull(board As uByte ptr) As Integer
  Dim i As Integer
    For i = 0 To 80
      If board[i] = 0 Then Return False
    Next i
    Return True
End Function

'-------------------------------------------------------------------------------
' Functions for safe logic solving

Function Solve_Rows(board As uByte ptr) As Integer
  Dim As Integer n, r, c, NumPotentials, NumSolved
  Dim As Integer px, py
    For n = 1 To 9
      For r = 0 To 8
        If NOT InRow(board, r, n) Then
          NumPotentials = 0
          For c = 0 To 8
            If board[c + (r * 9)] = 0 Then
              If NOT InCol(board, c, n) Then
                NumPotentials +=1
                px = c
                py = r
              End If
            End If
          Next c
          If NumPotentials = 1 Then
            If board[px + (py * 9)] = 0 Then
              NumSolved += 1              
              board[px + (py * 9)] = n
            End If
          End If
        End If
      Next r
    Next n
    Return NumSolved
End Function

Function Solve_Cols(board As uByte ptr) As Integer
  Dim As Integer n, r, c, NumPotentials, NumSolved
  Dim As Integer px, py
    For n = 1 To 9
      For c = 0 To 8
        If NOT InCol(board, c, n) Then
          NumPotentials = 0
          For r = 0 To 8
            If board[c + (r * 9)] = 0 Then
              If NOT InRow(board, r, n) Then
                NumPotentials += 1
                px = c
                py = r
              End If
            End If
          Next r
          If NumPotentials = 1 Then
            If board[px + (py * 9)] = 0 Then
              NumSolved += 1              
              board[px + (py * 9)] = n
            End If
          End If
        End If
      Next c
    Next n
    Return NumSolved
End Function

Function Solve_Boxes(board As uByte ptr) As Integer
  Dim As Integer n, b, x, y, r, c, NumPotentials, NumSolved
  Dim As Integer px, py
    For n = 1 To 9
      For b = 0 To 8
        If NOT InBox(board, b, n) Then
          NumPotentials = 0
          For y = 0 To 2
            For x = 0 To 2
              If Board[GetPos(x, y, b)] = 0 Then
                r = GetRow(x, y, b)
                c = GetCol(x, y, b)
                If (NOT InRow(board, r, n)) AND (NOT InCol(board, c, n)) Then
                  NumPotentials += 1
                  px = c
                  py = r
                End If
              End If
            Next x
          Next y
          If NumPotentials = 1 Then
            If board[px + (py * 9)] = 0 Then
              NumSolved += 1              
              board[px + (py * 9)] = n
            End If
          End If
        End If
      Next b
    Next n
    Return NumSolved
End Function

Sub Safe_Solve(board As uByte ptr)
  Dim As Integer q
    Do
      q = 0
      q += Solve_Rows(board)
      q += Solve_Cols(board)
      q += Solve_Boxes(board)
      If q = 0 Then Exit Do
    Loop
End Sub

' ---------------------------------------------------------------------------- '
' The main solving function, is recursive

Sub board_solve_inner(board_in As uByte ptr, board_out As uByte ptr, _
                      mode As Integer, NumSolutions As Integer)
  Dim candidates(81) As CANDIDATE_TYPE
  Dim num_candidates As Integer
  Dim As Integer i, b, y, x, r, c, n, lowest_prob, lowest_candidate
  Dim board_backup As uByte ptr
 
    Select Case mode
      Case 0
        If NumSolutions > 0 Then Exit Sub
      Case 1
        If NumSolutions > 1 Then Exit Sub
    End Select
 
    ' By performing this safe logical solve, we can often speed up execution
    Safe_Solve(board_in)
 
    If IsValid(board_in) AND IsFull(board_in) Then
      NumSolutions +=1
      memcpy(board_out, board_in, 81)
    End If
 
    If IsFull(board_in) Then Exit Sub
 
    ' work through board finding empty cells, and remembering the numbers that are
    ' valid in each cell.  This means we can then choose a cell with the lowest
    ' number of possibilities.
    lowest_prob = 9
   
    For b = 0 to 8
      For y = 0 To 2
        For x = 0 To 2
          r = GetRow(x, y, b)
          c = GetCol(x, y, b)
          If board_in[c + (r * 9)] = 0 Then
            candidates(num_candidates).x = x
            candidates(num_candidates).y = y
            candidates(num_candidates).b = b
            For n = 1 To 9
              If (NOT InRow(board_in, r, n)) AND _
                 (NOT InCol(board_in, c, n)) AND _
                 (NOT InBox(board_in, b, n)) Then
                candidates(num_candidates).possible_values(candidates(num_candidates).num_possible_values) = n
                candidates(num_candidates).num_possible_values += 1
              End If
            Next n
            If candidates(num_candidates).num_possible_values = 0 Then
              ' A 'bad' cell has been discovered, that cannot contain any number
              Exit Sub
            Else
              If lowest_prob > candidates(num_candidates).num_possible_values Then
                lowest_prob = candidates(num_candidates).num_possible_values
                lowest_candidate = num_candidates
              End If
            End If
            num_candidates += 1
          End If
        Next x
      Next y
    Next b
   
    ' Recurse with the new boards created by applying the possible values in turn
    ' to our chosen cell.
    For i = 1 To candidates(lowest_candidate).num_possible_values
      board_in[GetPos(candidates(lowest_candidate).x, _
                      candidates(lowest_candidate).y, _
                      candidates(lowest_candidate).b)] = _
                      candidates(lowest_candidate).possible_values(i - 1)
      board_backup = malloc(81)
      memcpy(board_backup, board_in, 81)
      board_solve_inner(board_in, board_out, mode, NumSolutions)
      memcpy(board_in, board_backup, 81)
      free(board_backup)
    Next i
End Sub

' ---------------------------------------------------------------------------- '
' The public sub that is called by program

Public Sub board_solve(board_in As uByte ptr, board_out As uByte ptr, _
                       mode As Integer, NumSolutions As Integer)
  Dim board_backup As uByte ptr

    NumSolutions = 0

    If NOT IsValid(board_in) Then Exit Sub
    If IsFull(board_in) Then Exit Sub
   
    board_backup = malloc(81)
    memcpy(board_backup, board_in, 81)    
    board_solve_inner(board_in, board_out, mode, NumSolutions)
    memcpy(board_in, board_backup, 81)
    free(board_backup)
End Sub

' ---------------------------------------------------------------------------- '
' Example usage
' ---------------------------------------------------------------------------- '

'------------
' Test boards

  ' 1905 SOLUTIONS (FROM WIKIPEDIA PAGE FOR SUDOKU)
  Dim TestBoard1(81) As uByte =  _
  { _
    5, 0, 6,  0, 2, 0,  9, 0, 3, _
    0, 0, 8,  0, 0, 0,  5, 0, 0, _
    0, 0, 0,  0, 0, 0,  0, 0, 0, _
  _
    6, 0, 0,  2, 8, 5,  0, 0, 9, _
    0, 0, 0,  9, 0, 3,  0, 0, 0, _
    8, 0, 0,  7, 6, 1,  0, 0, 4, _
  _
    0, 0, 0,  0, 0, 0,  0, 0, 0, _
    0, 0, 4,  0, 0, 0,  3, 0, 0, _
    2, 0, 1,  0, 5, 0,  6, 0, 7  _
  }
 
  ' NO SOLUTIONS
  Dim TestBoard2(81) As uByte =  _
  { _
    0, 1, 0,  0, 0, 0,  0, 0, 0, _
    0, 2, 0,  0, 0, 0,  0, 0, 0, _
    0, 3, 0,  0, 0, 0,  0, 0, 0, _
  _
    0, 4, 0,  0, 0, 0,  0, 0, 0, _
    0, 5, 0,  0, 0, 0,  0, 0, 0, _
    0, 0, 0,  0, 0, 0,  0, 0, 0, _
  _
    0, 0, 0,  0, 0, 6,  7, 8, 9, _
    0, 0, 0,  0, 0, 0,  0, 0, 0, _
    0, 0, 0,  0, 0, 0,  0, 0, 0  _
  }
 
  ' 1 SOLUTIONS
  Dim TestBoard3(81) As uByte =  _
  { _
    0, 0, 5,  0, 8, 0,  0, 0, 7, _
    0, 8, 7,  0, 0, 0,  0, 0, 0, _
    9, 0, 2,  1, 0, 0,  0, 8, 0, _
  _
    0, 0, 9,  0, 0, 4,  8, 1, 0, _
    0, 2, 6,  8, 9, 0,  0, 0, 0, _
    8, 0, 3,  0, 0, 0,  6, 7, 9, _
  _
    0, 0, 4,  7, 1, 8,  2, 9, 0, _
    0, 0, 8,  0, 0, 0,  7, 0, 1, _
    0, 0, 1,  3, 0, 0,  4, 6, 8  _
  }

  ' O SOLUTIONs - Slow
  Dim TestBoard4(81) As uByte =  _
  { _
    1, 0, 0,  2, 0, 0,  3, 0, 0, _
    0, 0, 0,  0, 0, 0,  0, 0, 0, _
    0, 0, 2,  0, 0, 4,  0, 9, 0, _
  _
    3, 0, 0,  1, 0, 0,  2, 0, 0, _
    0, 0, 0,  0, 0, 0,  0, 0, 0, _
    0, 9, 4,  0, 0, 2,  0, 0, 0, _
  _
    2, 0, 0,  3, 0, 0,  1, 0, 0, _
    0, 0, 0,  0, 0, 0,  0, 0, 0, _
    0, 0, 0,  0, 9, 0,  0, 0, 4  _
  }

' -----------------------------------
' Sub that PRINT's a board to console
 
  Sub Board_Print(board As uByte ptr)
    Dim As Integer x, y, v
      Cls
      For y = 0 To 8
        For x = 0 To 8
          If (x mod 3 = 0) AND (x <> 0) Then Print " ";
          v = board[x + (y * 9)]
          If v <> 0 Then
            Print Str(v);
          Else
            Print "-";
          End If
        Next x
        Print
        If (y + 1) mod 3 = 0 Then Print
      Next y
  End Sub

' ---------------------------------------------------------------------------- '
' Main example code
' ---------------------------------------------------------------------------- '

  Dim NumSolutions As Integer ' Is passed to board_solve, when board_solve
                              ' returns, will contain the number of solutions.
                              ' This depends on the mode chosen.
                             
  Dim board_out(81) As ubyte  ' A buffer that is passed to board_solve, when
                              ' board_solvereturns, will contain the last found
                              ' valid boardor will be unmodified if there are no
                              ' solutions
                             
  Dim t As Double             ' For clocking the time taken

    t = Timer ' Start Time
      ' MAIN CALL HERE!
      ' board_solve is *the* sub
      ' The first argument is a pointer to an array of 81 uBytes, that makes up
      '   the board.
      ' The second argument is a pointer to an array of 81 uBytes, that will be
      '   filled with the completed board, or unmodified if no solutions
      ' The third argument sets the mode.  
      '   0 will just find the first solved board
      '   1 will find the first two solutions, therefore this can be used to
      '     check if a board is valid (only one solution)
      '   2 will look for all possible solutions.  This can be very slow on
      '     some inputs, so should be used with care.
      ' The forth argument is an Integer, that will contain the number of
      '   possible solutions when board_solve returns.
      board_solve(@TestBoard3(0), @board_out(0), 0, NumSolutions)
    t = Timer - t ' Total Time
   
    Board_Print(@board_out(0)) ' Show solution
   
    Print NumSolutions & " Solutions"
    Print Int(t * 1000) & "ms"
   
    Sleep
   
Logged

EVEN MEN OF STEEL RUST.
Pages: [1] 2 3
  Print  
 
Jump to:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2015, Simple Machines Valid XHTML 1.0! Valid CSS!