Sudoku Solver (re-done)

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
podvornyak
Posts: 148
Joined: Nov 12, 2007 11:46
Location: Russia

Postby podvornyak » Oct 05, 2011 13:35

Forget to point - program exit with code 139 on sh script window. Runned directly form executable - work but on exit stuck.
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Oct 06, 2011 1:14

podvornyak wrote:Forget to point - program exit with code 139 on sh script window. Runned directly form executable - work but on exit stuck.

Hi podvornyak
I've reduced the file size with macros, and got rid of possible clashing variables with Linux, as best I could.
Also, the exit should be ok now.
You can use esc instead of the cross on the big screen or quit on the small, but it shouldn't be necessary.
You can have screen 20 if you like, for the inputs, but screen 9 at 8 bit graphics is fixed to free resources for speed.

I can't use Ubuntu because it has no drivers for my usb modem, so I use pclinuxos, which is the only distro I have found suitable.

Please remember that I shell gedit for linux, maybe Ubunto doesn't use gedit, you may have to change the shell instruction.
I think perhaps that file size in Kb defines whether or not it can be posted intact, and not the number of lines.
I see that fxm and badidea cleverly produced an alternative sub, I havn't tested them out for speed, but I think that defining arrays and/or using mod and int would slow things down.

Code: Select all


'Sodoku solver
Type d2
    As Integer x,y,w,h,index
    As Uinteger colour
    As String caption
End Type
#macro Typed2(num,_x,_y,_w,_h,_index,_colour,_caption)
num.x=_x:num.y=_y:num.w=_w:num.h=_h:num.index=_index:num.colour=_colour:num.caption=_caption
#endmacro
#define xs exit sub
#define xf exit function
Declare Sub thickline(x1 As Double,_
y1 As Double,_
x2 As Double,_
y2 As Double,_
thickness As Double,_
colour As Uinteger,_
im As Any Pointer=0)
Dim Shared As Integer getout
Declare Sub main
Declare  Sub setboxes
Declare Sub inspect_boxes(mouse As d2)
Declare Sub drawbox(p() As d2,i As Integer,col As Uinteger,th As Single=1,pnt As String="paint",im As Any Pointer=0)
Function inbox(p1() As d2,p As d2,i As Integer) As Integer
    Return (p.x>p1(i).x)*(p.x<(p1(i).x+p1(i).w))*(p.y>p1(i).y)*(p.y<(p1(i).y+p1(i).h))
End Function
#macro incircle(cx,cy,radius,x,y)
(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro
Declare Function roundup (a As Double, b As Integer) As Single
Declare Sub solve3 ()
Declare Sub textend ()
Declare Sub printbox2 (s As String)
Declare Sub timeout ()
Declare Sub setinrow ()
Declare Sub solve2 ()
Declare Sub whatsize (n As String)
Declare Sub phase (number As Integer)
Declare Sub setkeep ()
Declare Sub makekeep (m As Integer)
Declare Function ninebox (m As Integer) As Integer
Declare Sub makehops ()
Declare Sub makeb ()
Declare Sub actions(bo1 As String,bo2 As String,label As String,action As String)
Declare Sub setsquare (y As Integer, x As Integer)
Declare Function boxcheck (in() As Integer, m As Integer, al As Integer, dow As Integer) As Integer
Declare Sub dummy ()
Declare Sub setup ()
Declare Sub build (z As Integer)
Declare Function bigcheck () As Integer
Declare Function weecheck (m As Integer) As Integer
Declare Function cycle (x As Integer) As Integer
Declare Sub solve ()
Declare Function runcheck (n As Integer, x As Integer, y As Integer, m As Integer) As Integer
Declare Function checkerr (m2() As Integer, x As Integer, y As Integer) As Integer
Declare Sub grid ()
Declare Sub box2 (s As String)
Const ok = 1
Const notok = 0
Dim Shared mglobal(9,9) As Integer
Dim Shared square As Integer
Dim Shared bb(1 To 9) As Integer
Dim Shared hopper(1 To 9) As Integer
Dim As Integer a1,b1
Dim Shared inrow(9, 9) As Integer
Dim Shared incol(9, 9) As Integer
Dim Shared keep(9, 9) As Integer
Dim Shared startall As Double
Dim Shared endall As Double
Dim Shared boxes As Integer
Dim Shared As d2 big(9*9),p,nums(9),info(1),help(0)
Dim Shared As Integer xres,yres,dragflag,helpflag,errorflag
Dim Shared As String dragnum
'____________________
Screen 19,32
Screeninfo (xres,yres)
setboxes
main
startall=Timer
Cls
boxes = 1
grid
For a1 = 1 To 9
    For b1 = 1 To 9
        keep(a1, b1) = mglobal(a1, b1)
    Next b1
Next a1 
box2("n")
setup
whatsize("show")
solve
'_____________________
Function bigcheck As Integer
    Dim a As Integer
    Dim b As Integer
    For a = 1 To 9
        For b = 1 To 9
            If inrow(a, b) = 0 Then
                bigcheck = notok
                Exit Function
            End If
            If runcheck(inrow(a, b), a, b, 0) = notok Then
                bigcheck = notok
                Exit Function
            End If
        Next b
    Next a
    bigcheck = ok
End Function

Sub box2 (s As String)
    Dim a1 As Integer
    Dim b1 As Integer
    Color 2, 4
    For a1 = 1 To 9
        For b1 = 1 To 9
            Locate (2 * a1), 25 + 4 * b1
            If mglobal(a1, b1) <> 0 Then Color 1, 4
            If s = "c" Then Print incol(a1, b1)
            If s = "r" Then Print inrow(a1, b1)
            If s = "k" Then Print keep(a1, b1)
            If s = "n" Then Print mglobal(a1,b1)
            Color 2, 4
        Next b1
    Next a1
    Color 15, 4
End Sub
Function boxcheck (in() As Integer, m As Integer, al As Integer, dow As Integer) As Integer
    Dim As Integer along=Any,down=Any,a=Any,d=Any,c,flag
    boxcheck = ok
    If in(al, dow) = 0 Then
        boxcheck = ok
        xf
    End If
    #macro _check()
    flag=1
    If c > 1 Then
        boxcheck = notok
        xf
    End If
    #endmacro
    #macro set(f1,f2,s1,s2)
    boxcheck=ok
    For along=f1
        For down=f2
            c=0
            For a=s1
                For d=s2
                    flag=0
                    If in(along, down) = 0 Then:_check():End If
                    If flag=0 Then
                        If in(along, down) = in(a, d) Then c = c + 1
                        _check()
                    End If
                Next d
            Next a
        Next down
    Next along
    #endmacro
    If m=1 Then :set(1 To 3,1 To 3,1 To 3,1 To 3):End If
    If m=2 Then :set(1 To 3,4 To 6,1 To 3,4 To 6):End If
    If m=3 Then :set(1 To 3,7 To 9,1 To 3,7 To 9):End If
    If m=4 Then :set(4 To 6,1 To 3,4 To 6,1 To 3):End If
    If m=5 Then :set(4 To 6,4 To 6,4 To 6,4 To 6):End If
    If m=6 Then :set(4 To 6,7 To 9,4 To 6,7 To 9):End If
    If m=7 Then :set(7 To 9,1 To 3,7 To 9,1 To 3):End If
    If m=8 Then :set(7 To 9,4 To 6,7 To 9,4 To 6):End If
    If m=9 Then :set(7 To 9,7 To 9,7 To 9,7 To 9):End If
   
End Function
Sub build (z As Integer)
    Dim  As Integer _p=Any,_q=Any
    #macro set(_a1,_a2,_b1,_b2)
    For _p=_a1 To _a2
        For _q=_b1 To _b2
            incol(_q, _p) = inrow(_q, _p)   
        Next _q
    Next _p
    #endmacro 
    If z=1 Then:set(1,3,1,3):xs:End If
    If z=2 Then:set(1,3,4,6):xs:End If
    If z=3 Then:set(1,3,7,9):xs:End If
    If z=4 Then:set(4,6,1,3):xs:End If
    If z=5 Then:set(4,6,4,6):xs:End If
    If z=6 Then:set(4,6,7,9):xs:End If
    If z=7 Then:set(7,9,1,3):xs:End If
    If z=8 Then:set(7,9,4,6):xs:End If
    If z=9 Then:set(7,9,7,9):xs:End If
   
End Sub
Function checkerr (m2() As Integer, x As Integer, y As Integer) As Integer
    Dim count As Integer
    For count = 1 To 9
        If count = y Then Goto endrow
        If m2(x, y) <> 0 Then
            If m2(x, y) = m2(x, count) Then
                checkerr = notok
                Exit Function
            End If
        End If
        checkerr = ok
        endrow:
    Next count
    For count = 1 To 9
        If count = x Then Goto endcol
        If m2(x, y) <> 0 Then
            If m2(x, y) = m2(count, y) Then
                checkerr = notok
                Exit Function
            End If
        End If
        checkerr = ok
        endcol:
    Next count
End Function

Function cycle (x As Integer) As Integer
    If x Mod 9 = 0 Then
        cycle = 9
    Else
        cycle = x Mod 9
    End If
End Function
Sub dummy ()
    If Inkey$ <> "" Then
        Dim what As String 
        doagain:
        Locate 4, 4
        Print "q for quit"
        Print "   c to continue"
        what = Input$(1)
        what = Lcase$(what)
        If Instr("qcqc", what) = 0 Then
            Print "mistake, q/c"
            Goto doagain
        End If
        Locate 4, 4
        Print "           "
        Print "                    "
        If what = "q" Then End
        If what = "c" Then Exit Sub
    End If
End Sub
Sub grid
    Dim As Integer xtemp,ytemp,xpix,ypix,col,col2
    For a2 As Integer=1 To 10
        For b2 As Integer=1 To 10
            If (a2-1) Mod 3 =0 Then
                col=7
            Else
                col=8
            End If
            If (b2-1) Mod 3 =0 Then
                col2=7
            Else
                col2=8
            End If
            xtemp=25+4*b2
            xpix = (640 * (xtemp - 1)) / 79-10
            ytemp = 2 * a2
            ypix = (350 * (ytemp - 1)) / 25 - 8
            If b2<>10 Then Line(xpix,ypix)-(xpix+32,ypix),col
            If a2<>10 Then Line(xpix,ypix)-(xpix,ypix+28),col2
        Next b2
    Next a2
End Sub
Sub makeb
    Dim As Integer x,y,marker
    For x = 1 To 9
        dooagain:
        marker = ok
        bb(x) = Int(((9 - 1) + 1) * Rnd + 1)
        If x > 1 Then
            For y = 1 To x - 1
                If bb(x) = bb(y) Then
                    marker = notok
                    Exit For
                End If
            Next y
        End If
        If marker = notok Then Goto dooagain
    Next x
End Sub
Sub makehops
    Dim As Integer x,y,marker
    For x = 1 To 9
        dooagain2:
        marker = ok
        hopper(x) = Int(((9 - 1) + 1) * Rnd + 1)
        If x > 1 Then
            For y = 1 To x - 1
                If hopper(x) = hopper(y) Then
                    marker = notok
                    Exit For
                End If
            Next y
        End If
        If marker = notok Then Goto dooagain2
    Next x
End Sub
Sub makekeep (m As Integer)
    Dim  As Integer _p=Any,_q=Any
    #macro set(_a1,_a2,_b1,_b2)
    For _p=_a1 To _a2
        For _q=_b1 To _b2
            keep(_p,_q)=incol(_p,_q)
        Next _q
    Next _p
    #endmacro
    If m=1 Then:set(1,3,1,3):xs:End If
    If m=2 Then:set(1,3,4,6):xs:End If
    If m=3 Then:set(1,3,7,9):xs:End If
    If m=4 Then:set(4,6,1,3):xs:End If
    If m=5 Then:set(4,6,4,6):xs:End If
    If m=6 Then:set(4,6,7,9):xs:End If
    If m=7 Then:set(7,9,1,3):xs:End If
    If m=8 Then:set(7,9,4,6):xs:End If
    If m=9 Then:set(7,9,7,9):xs:End If
   
End Sub
Function ninebox (m As Integer) As Integer
    ninebox = notok
    Dim  As Integer _p=Any,_q=Any
    #macro set(_a1,_a2,_b1,_b2)
    For _p=_a1 To _a2
        For _q=_b1 To _b2
            If keep(_p,_q)=0 Then xf
        Next _q
    Next _p
    #endmacro
    If m=1 Then:set(1,3,1,3):End If
    If m=2 Then:set(1,3,4,6):End If
    If m=3 Then:set(1,3,7,9):End If
    If m=4 Then:set(4,6,1,3):End If
    If m=5 Then:set(4,6,4,6):End If
    If m=6 Then:set(4,6,7,9):End If
    If m=7 Then:set(7,9,1,3):End If
    If m=8 Then:set(7,9,4,6):End If
    If m=9 Then:set(7,9,7,9):End If
    ninebox = ok
End Function
Sub phase (number As Integer)
    actions("-1","-1","solving","phase "+Str$(number))
End Sub
Sub printbox2 (s As String)
    Open "results.txt" For Output As #1
    For a1 As Integer = 1 To 9
        For b1 As Integer = 1 To 9
            Print #1, inrow(a1,b1);
        Next b1
        Print #1, " "
    Next a1
    Close #1
    Shell "gedit results.txt"
    Shell "notepad.exe results.txt"
End Sub
Function roundup (a As Double, b As Integer) As Single
    Dim As Single y,i,r
    y = (Abs(a) - Int(Abs(a))) * (10 ^ b)
    i = Int(y)
    y = y - i
    If y >= .5 Then i = i + 1
    i = i / (10 ^ b)
    r = Int(Abs(a)) + i
    If a < 0 Then r = -r
    roundup = r
End Function
Function runcheck (n As Integer, x As Integer, y As Integer, m As Integer) As Integer
    Dim As Integer a=Any,d=Any,count=Any
    For count = 1 To 9
        If count = y Then Goto nextinrow2
        If n = inrow(x, count) Then
            runcheck = notok
            Exit Function
        End If
        runcheck = ok
        nextinrow2:
    Next count
    For count = 1 To 9
        If count = x Then Goto endcol3
        If n = inrow(count, y) Then
            runcheck = notok
            Exit Function
        End If
        runcheck = ok
        endcol3:
    Next count
    #macro set(a1,a2)
    For a=a1
        For d=a2
            If n = inrow(a, d) Then
                runcheck = notok
                xf
            End If
        Next d
    Next a
    #endmacro
    If m=1 Then:set(1 To 3,1 To 3):End If
    If m=2 Then:set(1 To 3,4 To 6):End If
    If m=3 Then:set(1 To 3,7 To 9):End If
    If m=4 Then:set(4 To 6,1 To 3):End If
    If m=5 Then:set(4 To 6,4 To 6):End If
    If m=6 Then:set(4 To 6,7 To 9):End If
    If m=7 Then:set(7 To 9,1 To 3):End If
    If m=8 Then:set(7 To 9,4 To 6):End If
    If m=9 Then:set(7 To 9,7 To 9):End If
   
End Function
Sub setinrow
    Dim along As Integer
    Dim down As Integer
    For along = 1 To 9
        For down = 1 To 9
            inrow(along, down) = keep(along, down)
        Next down
    Next along
End Sub
Sub setkeep
    dim as integer a=any,b=any
    For a = 1 To 9
        For b = 1 To 9
            keep(a, b) = mglobal(a, b)
        Next b
    Next a
End Sub
Sub setsquare (y As Integer, x As Integer)
    #macro set(a,b,num)
    If  a Then
        If  b Then
            square=num
            xs
        End If
    End If
    #endmacro
    If y <= 3 And x <= 3 Then
        square = 1
    End If
    set(y<= 3,x> 3 And x < 7,2)
    set(y<= 3,x> 6 And x <= 9,3)
    set(y > 3 And y < 7,x <= 3,4)
    set(y > 3 And y < 7,x > 3 And x < 7,5)
    set(y > 3 And y < 7,x > 6 And x <= 9,6)
    set(y > 6 And y <= 9,x <= 3,7)
    set(y > 6 And y <= 9,x > 3 And x < 7,8)
    set(y > 6 And y <= 9,x > 6 And x <= 9,9)
End Sub
Sub setup
    Dim a1 As Integer
    Dim b1 As Integer
    For a1 = 1 To 9
        For b1 = 1 To 9
            inrow(a1, b1) = mglobal(a1, b1)
        Next b1
    Next a1
End Sub
Sub solve
    Dim As Integer along,down,n,hop,hops,skip,b,flag,flag2,first,middle,zz,zzz,zzb
    Dim madeincol As Integer
    Dim hopcount As Integer
    Dim As Single start,finish
    actions("-1","-1","solving","phase 1")
    zzb = 0
    madeincol = notok
    Randomize Timer
    startup:
    Do
        make:
        hopcount = 0
        Locate 23, 52
        Print Chr$(flag2 Mod 4)
        dummy ()
        If flag2 > flag Then flag = flag2
        flag2 = 0
        makehops
        For hops = 1 To 9
            flag2 = flag2 + 1
            hop = hopper(hops)
            If hop = 1 Then skip = 2
            If hop = 2 Then skip = 2
            If hop = 3 Then skip = 2
            If hop = 4 Then skip = 5
            If hop = 5 Then skip = 5
            If hop = 6 Then skip = 5
            If hop = 7 Then skip = 8
            If hop = 8 Then skip = 8
            If hop = 9 Then skip = 8
            If hop <= 3 Then middle = 3 * hop - 1
            If hop >= 4 And hop <= 6 Then
                middle = 3 * hop - 10
            End If
            If hop >= 7 And hop <= 9 Then
                middle = 3 * hop - 19
            End If
            start = Timer
            Do
                hopcount = hopcount + 1
                boxer:
                For along = skip - 1 To skip + 1
                    For down = middle - 1 To middle + 1
                        If mglobal(along, down) = 0 Then
                            makeb
                            For n = 1 To 9
                                If runcheck(bb(n), along, down, hop) = ok Then
                                    inrow(along, down) = bb(n)
                                    Exit For
                                End If
                            Next n
                        End If
                    Next down
                Next along
                finish = Timer
               
                If hopcount > 40 Then
                    setup
                    Goto make
                End If
            Loop Until weecheck(hop) = ok
            If flag2 >= 8 Then     
                For zzz = 1 To 9
                    build(zzz)
                Next zzz
                madeincol = ok
                zzb = zzb + 1
            End If
            If zzb >= boxes And madeincol = ok Then
                setup
                setkeep
                box2 ("c")
                solve3                                     
            End If
        Next hops
        If bigcheck = notok Then
            setup
            Goto make                   
        End If
    Loop Until bigcheck = ok
    endall = Timer
End Sub
Sub solve2
    Dim As Integer along,down,n,hop,hops,skip,b,flag,flag2,first,middle,zz,zzz,zzb
    Dim start2 As Single
    Dim finish2 As Single
    Dim xxx As Integer
    Dim hopcount As Integer
    Dim shiftcount As Integer
    Dim As Single start,finish
    Randomize Timer
    startup2:
    For xxx = 1 To 18
        zz = cycle(xxx)
        makekeep(zz)       
        setinrow           
        If ninebox(zz) = notok Then Goto zznext             
        actions(Str$(zz),"-1","solving","phase 3  ")
        box2 ("n")               
        box2 ("k")
        shiftcount = 0
        make2:
        shiftcount = shiftcount + 1
        hopcount = 0
        If flag2 > flag Then flag = flag2
        flag2 = 0
        makehops
        For hops = 1 To 9
            flag2 = flag2 + 1
            hop = hopper(hops)
            If hop = 1 Then skip = 2
            If hop = 2 Then skip = 2
            If hop = 3 Then skip = 2
            If hop = 4 Then skip = 5
            If hop = 5 Then skip = 5
            If hop = 6 Then skip = 5
            If hop = 7 Then skip = 8
            If hop = 8 Then skip = 8
            If hop = 9 Then skip = 8
            If hop <= 3 Then middle = 3 * hop - 1
            If hop >= 4 And hop <= 6 Then
                middle = 3 * hop - 10
            End If
            If hop >= 7 And hop <= 9 Then
                middle = 3 * hop - 19
            End If
            Do
                hopcount = hopcount + 1
                dummy ()       
                For along = skip - 1 To skip + 1
                    For down = middle - 1 To middle + 1
                        If keep(along, down) = 0 Then       
                            makeb
                            For n = 1 To 9
                                If runcheck(bb(n), along, down, hop) = ok Then
                                    inrow(along, down) = bb(n)
                                    Exit For
                                End If
                            Next n
                        End If
                    Next down
                Next along
                finish = Timer
                If hopcount > 40 Then
                    setinrow           
                    Goto make2
                End If
            Loop Until weecheck(hop) = ok
            missahop:
            If shiftcount > 200 Then
                setkeep
                Goto zznext
            End If
        Next hops
        If bigcheck = ok Then Goto getout
        zznext:
    Next xxx
    setkeep
    Erase incol
    setup
    solve
    getout:
    endall = Timer
    box2 ("r")
    timeout
    actions("-1","-1","            ","                   ")
    actions("-1","-1","solved","Check completed")
    whatsize("")
    Locate 10, 10
    Print "finished"
    textend
    End
End Sub
Sub solve3
    Dim As Integer along,down,n,hop,hops,skip,b,flag,flag2,first,middle,zz,zzz,zzb
    Dim start2 As Single
    Dim finish2 As Single
    Dim xxx As Integer
    Dim yyy As Integer
    Dim hopcount As Integer
    Dim shiftcount As Integer
    Dim As Single start,finish
    Randomize Timer
    startup3:
    setkeep           
    For xxx = 1 To 8
        makekeep(xxx)   
        If ninebox(xxx) = notok Then Goto xxxnext3
        For yyy = xxx + 1 To 9
            makekeep(yyy)   
            If ninebox(yyy) = notok Then Goto yyynext3
            setinrow           
            box2 ("k")
            actions(Str$(xxx),Str$(yyy),"solving","phase 2")
            shiftcount = 0
            make3:
            shiftcount = shiftcount + 1
            hopcount = 0
            If flag2 > flag Then flag = flag2
            flag2 = 0
            makehops
            For hops = 1 To 9
                flag2 = flag2 + 1
                hop = hopper(hops)
                If hop = 1 Then skip = 2
                If hop = 2 Then skip = 2
                If hop = 3 Then skip = 2
                If hop = 4 Then skip = 5
                If hop = 5 Then skip = 5
                If hop = 6 Then skip = 5
                If hop = 7 Then skip = 8
                If hop = 8 Then skip = 8
                If hop = 9 Then skip = 8
                If hop <= 3 Then middle = 3 * hop - 1
                If hop >= 4 And hop <= 6 Then
                    middle = 3 * hop - 10
                End If
                If hop >= 7 And hop <= 9 Then
                    middle = 3 * hop - 19
                End If
                start = Timer
                Do
                    hopcount = hopcount + 1
                    dummy ()       
                    For along = skip - 1 To skip + 1
                        For down = middle - 1 To middle + 1
                            If keep(along, down) = 0 Then   
                                makeb
                                For n = 1 To 9
                                    If runcheck(bb(n), along, down, hop) = ok Then
                                        inrow(along, down) = bb(n)
                                        Exit For
                                    End If
                                Next n
                            End If
                        Next down
                    Next along
                    finish = Timer
                    If hopcount > 40 Then
                        setinrow           
                        Goto make3
                    End If
                Loop Until weecheck(hop) = ok
                missahop3:
                If shiftcount > 200 Then
                    setup
                    setkeep
                    makekeep(xxx)
                    Goto yyynext3
                End If
            Next hops
            If bigcheck = ok Then Goto getout3
            yyynext3:
        Next yyy
        setup
        setkeep
        xxxnext3:
    Next xxx
    setkeep
    setup
    Locate 9, 1
    Print "          "
    solve2
    getout3:
    endall = Timer
    box2 ("r")
    timeout
    actions("-1","-1","            ","                   ")
    actions("-1","-1","","Check completed")
    whatsize("")
    Locate 10, 10
    Print "finished"
    textend
    End
End Sub
Sub textend
    Dim As Integer mx,my,mw,mb
    Do
        Getmouse mx,my,mw,mb
        Screenlock
        Circle(550,50),30,,,,,f
        Circle(550,50),30,9
        Draw String(540,45),"Quit",3
        If incircle(550,50,30,mx,my) And mb<>0 Then
            Screenunlock
            End
        End If
        Circle(550,150),30,,,,,f
        Circle(550,150),30,9
        Draw String(540,145),"Save",3
        If incircle(550,150,30,mx,my) And mb<>0 Then
            Screenunlock
            printbox2("r")
            Exit Sub
        End If
        Screenunlock
        Sleep 1,1
    Loop Until Inkey=Chr(27)
End Sub
Sub timeout
    Dim seconds As Double
    Dim minutes As Double
    seconds = endall - startall
    minutes = seconds / 60
    Locate 13, 2
    If seconds <= 60 Then
        Print "Time = ";
        Print Using "##.#";roundup(Cdbl(seconds), 1);
        Print "s"
    Else
        seconds = roundup(Cdbl((minutes - Int(minutes)) * 60), 1)
        Print "Time = ";Int(minutes);
        Print "m ";
        Print Using "##.#";seconds;
        Print "s"
    End If
End Sub
Function weecheck (m As Integer) As Integer
    Dim As Integer along=Any,down=Any,a=Any,d=Any,c
    #macro set(f1,f2,s1,s2)
    weecheck=ok
    For along=f1
        For down=f2
            c=0
            For a=s1
                For d=s2
                    If inrow(along, down) = 0 Then
                        weecheck = notok
                        Exit Function
                    End If
                    If inrow(along, down) = inrow(a, d) Then c = c + 1
                    If c > 1 Then
                        weecheck = notok
                        Exit Function
                    End If
                Next d
            Next a
        Next down
    Next along
    #endmacro
    If m=1 Then:set(1 To 3,1 To 3,1 To 3,1 To 3):End If
    If m=2 Then:set(1 To 3,4 To 6,1 To 3,4 To 6):End If
    If m=3 Then:set(1 To 3,7 To 9,1 To 3,7 To 9):End If
    If m=4 Then:set(4 To 6,1 To 3,4 To 6,1 To 3):End If
    If m=5 Then:set(4 To 6,4 To 6,4 To 6,4 To 6):End If
    If m=6 Then:set(4 To 6,7 To 9,4 To 6,7 To 9):End If
    If m=7 Then:set(7 To 9,1 To 3,7 To 9,1 To 3):End If
    If m=8 Then:set(7 To 9,4 To 6,7 To 9,4 To 6):End If
    If m=9 Then:set(7 To 9,7 To 9,7 To 9,7 To 9):End If
End Function
Sub whatsize(n As String)
    Locate 22, 4
    If n="show" Then
        Print "Press any key for quit option"
        startall = Timer
    Else
        Print "                                            "
    End If
End Sub
Sub actions(bo1 As String,bo2 As String,label As String,action As String)
    Locate 21,53
    Print label
    Locate 23, 53
    Print action
    Line(400,300)-(600,330),,B
    Locate 21,53
    If label="-1" Then label=""
    Print label
    Locate 23, 52
    Color 15
    If bo1="-1" Then bo1=""
    If bo2="-1" Then bo2=""
    If action="-1" Then action=""
    Print bo1+" ";bo2;"   "+action
End Sub
Sub thickline(x1 As Double,_
    y1 As Double,_
    x2 As Double,_
    y2 As Double,_
    thickness As Double,_
    colour As Uinteger,_
    im As Any Pointer=0)
    Dim p As Uinteger=Rgb(255, 255, 254)
    If thickness<2 Then
        Line(x1,y1)-(x2,y2),colour
    Else               
        Dim As Double h=Sqr((x2-x1)^2+(y2-y1)^2):If h=0 Then h=1e-6
        Dim As Double s= (y1-y2)/h ,c=(x2-x1)/h
        For x As Integer=1 To 2
            Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),p
            Line im,(x1-s*thickness/2,y1-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
            Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x1-s*thickness/2,y1-c*thickness/2),p
            Line im,(x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
            Paint im,((x1+x2)/2, (y1+y2)/2), p, p
            p=colour
        Next x
    End If
End Sub
Sub drawbox(p() As d2,i As Integer,col As Uinteger,th As Single=1,pnt As String="paint",im As Any Pointer=0)
    thickline(p(i).x,p(i).y,p(i).x+p(i).w,p(i).y,th,col,im)
    thickline(p(i).x+p(i).w,p(i).y,p(i).x+p(i).w,p(i).y+p(i).h,th,col,im)
    thickline(p(i).x+p(i).w,p(i).y+p(i).h,p(i).x,p(i).y+p(i).h,th,col,im)
    thickline(p(i).x,p(i).y+p(i).h,p(i).x,p(i).y,th,col,im)
    If pnt="paint" Then
        var xc=(p(i).x+p(i).x+p(i).w)/2
        var yc=(p(i).y+p(i).y+p(i).h)/2
        Paint(xc,yc),col,col
        If  i=0 Then p(i).caption=""
        Draw String(xc-5,yc-5),p(i).caption
    End If
End Sub
Sub setboxes
    Dim As Integer count
    For z2 As Integer = 0 To 8
        For z As Integer=0 To 8
            count=count+1
            Select Case count
            Case 1,2,3,10,11,12,19,20,21,7,8,9,16,17,18,25,26,27
                big(count).colour=Rgb(200,0,0)
            Case 55,56,57,64,65,66,73,74,75,61,62,63,70,71,72,79,80,81,31,32,33,40,41,42,49,50,51
                big(count).colour=Rgb(200,0,0)
            Case Else
                big(count).colour=Rgb(0,200,0)
            End Select
            Typed2(big(count),(10+z*33),(10+z2*33),30,30,count,big(count).colour,"")
        Next z
    Next z2
    For z As Integer=0 To 9
        typed2(nums(z),(.8*xres),(z*53),50,50,z,Rgb(100,100,100),Str(z))
    Next z
    typed2(info(1),(.5*xres),0,70,20,1,Rgb(255,0,0),"?")
    typed2(help(0),(.4*xres),21,310,200,0,Rgb(255,255,255),"")
End Sub
Sub inspect_boxes(mouse As d2)
    #macro doublecheck(p1,p2)
    setsquare(p1,p2)
    If checkerr(mglobal(), p1, p2) = notok Or boxcheck(mglobal(), square, p1, p2) = notok Then
        Beep
        big(z).caption=""
        mglobal(p1,p2)=0
        errorflag=1
    Else
        errorflag=0
    End If
    #endmacro
    Dim As Integer vd
    Dim As Uinteger edge,numedge
    For z As Integer=0 To Ubound(big)
        If inbox(big(),mouse,big(z).index) Then
            edge=Rgb(200,200,0)
        Else
            edge=Rgb(00,00,200)
        End If
        'numbers _
        If z<=9 Then
            If inbox(nums(),mouse,nums(z).index) Then
                numedge=Rgb(200,200,0)
            Else
                numedge=Rgb(0,0,200)
            End If
        End If
        'numbers
        If z<=9 Then
            drawbox(nums(),nums(z).index,nums(z).colour,1)
            drawbox(nums(),nums(z).index,numedge,2,"")
            If inbox(nums(),mouse,nums(z).index) And mouse.w<>0 Then
                dragflag=1
                dragnum=nums(z).caption
                errorflag=0
            End If
            '__
        End If
        drawbox(big(),big(z).index,big(z).colour,1)
        drawbox(big(),big(z).index,edge,2,"")
        If inbox(big(),mouse,big(z).index) And mouse.w<>0 Then
            big(z).caption=dragnum
            vd=z
            Select Case z
            Case 1 To 9
                mglobal(1,vd)=Valint(dragnum)
                doublecheck(1,vd)
            Case 10 To 18
                mglobal(2,vd-9)=Valint(dragnum)
                doublecheck(2,(vd-9))
            Case 19 To 27
                mglobal(3,vd-18)=Valint(dragnum)
                doublecheck(3,(vd-18))
            Case 28 To 36
                mglobal(4,vd-27)=Valint(dragnum)
                doublecheck(4,(vd-27))
            Case 37 To 45
                mglobal(5,vd-36)=Valint(dragnum)
                doublecheck(5,(vd-36))
            Case 46 To 54
                mglobal(6,vd-45)=Valint(dragnum)
                doublecheck(6,(vd-45))
            Case 55 To 63
                mglobal(7,vd-54)=Valint(dragnum)
                doublecheck(7,(vd-54))
            Case 64 To 72
                mglobal(8,vd-63)=Valint(dragnum)
                doublecheck(8,(vd-63))
            Case 73 To 81
                mglobal(9,vd-72)=Valint(dragnum)
                doublecheck(9,(vd-72))
            End Select
            dragflag=0
        End If
        If inbox(big(),mouse,big(z).index) Then
            Draw String(mouse.x,mouse.y-10),dragnum
            If dragnum="" Then Draw String(mouse.x,mouse.y-10),"///"
        End If
        'if not inbox(big(),mouse,big(z).index) Then errorflag=0
    Next z
    drawbox(info(),1,info(1).colour,1)
    drawbox(info(),1,Rgb(200,200,200),3,"")
    If inbox(info(),mouse,1) And mouse.w<>0 Then
        helpflag=1
    End If
    If helpflag Then
        drawbox(help(),0,help(0).colour,1)
        drawbox(help(),0,Rgb(200,0,200),3,"")
        Draw String(.41*xres,25),"Click a Grey box to fetch a digit",Rgb(0,0,0)
        Draw String(.41*xres,40),"Carry the digit to the Sudoku",Rgb(0,0,0)
        Draw String(.41*xres,55),"Click on a Sudoku box to deposit it",Rgb(0,0,0)
        Draw String(.41*xres,80),"Carry the blank to erase a mistake",Rgb(0,0,0)
        Draw String(.41*xres,100),"Click solve when ready",Rgb(0,0,0)
        If inbox(help(),mouse,0) And mouse.w<>0 Then
            helpflag=0
        End If
    End If
    Circle(.97*xres,.05*yres),20,Rgb(200,0,0),,,,f
    Circle(.97*xres,.05*yres),20,Rgb(255,255,255)
    Draw String(.965*xres,.04*yres),"X"
    If incircle(.965*xres,.04*yres,20,mouse.x,mouse.y) And  mouse.w<>0 Then
        Screenunlock
        End
    End If
    Circle (.5*xres,.8*yres),30,Rgb(200,200,200),,,,f
    Circle (.5*xres,.8*yres),30,Rgb(0,200,0)
    Draw String(.48*xres,.79*yres),"Solve",Rgb(0,0,0)
    'SOLVE
    If incircle(.5*xres,.8*yres,30,mouse.x,mouse.y) And  mouse.w<>0 Then
        getout=1
        Screenunlock
        Screen 9
        Exit Sub
    End If
End Sub
Sub main
    Dim As Integer mx,my,mw,mb
    Dim As d2 mouse
    Dim As Uinteger edge
    Do
        If getout=1 Then Exit Sub
        Getmouse(mx,my,mw,mb)
        mouse.x=mx:mouse.y=my:mouse.w=mb
        Screenlock
        Cls
        If errorflag Then
            Draw String(.4*xres,yres/2),"ERROR:"
            Draw String(.4*xres,yres/2+30),"Number  " & dragnum &" has been misplaced"
        End If
        inspect_boxes(mouse)
        If dragflag Then
            If dragnum="" Then
                Draw String(mx,my-10),"///"
            Else
                Draw String(mx,my-10),dragnum
            End If
        End If
        Screenunlock
        Sleep 1,1
    Loop Until Inkey=Chr(27) 
End Sub

podvornyak
Posts: 148
Joined: Nov 12, 2007 11:46
Location: Russia

Postby podvornyak » Oct 06, 2011 2:26

Well. Now executing from shell, but still stuck on exit. Probably it is about you mentioned already - exit before screenunlock.
Update.
To Dodicat: Yes it helps - "End" at the last "Sub".
integer
Posts: 386
Joined: Feb 01, 2007 16:54
Location: usa

Postby integer » Oct 10, 2011 4:28

This is good for the solution of a puzzle.

Have you tried to generate the puzzles?

The question I would like to have answered:
What is the MINIMUM number of cells required to yield a unique solution?
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Oct 10, 2011 9:28

integer wrote:This is good for the solution of a puzzle.

Have you tried to generate the puzzles?

The question I would like to have answered:
What is the MINIMUM number of cells required to yield a unique solution?

To generate a sudoku just click solve without putting any numbers in.
Then pick at least 17 randomly.
I could make a game from the interface easily enough, but I don't like computer games very much, especially sudoku.
The minimum number required for a unique solution is unsolved, so some of the 17 choices may not yeild unique solutions.
The more you pick above 17, the more likely the unique solution.
Anyway, thanks for trying it out, I've edited the original post for smooth running in Linux and toned down the colours a bit.
If you get up at the crack of dawn, get a newspaper, solve the Sudoku, you might win a few dollars.
If you win a million then don't forget poor old Dodicat over the sea.
BasicScience
Posts: 489
Joined: Apr 18, 2008 4:09
Location: Los Angeles, CA
Contact:

Postby BasicScience » Nov 06, 2011 17:12

What is the method behind the alorithm used to find a solution? Code was a bit dense to figure it out from there.

I entered a "beware challenging" sudoku from the Will Shortz book. It took 5 min 55 sec to solve, but eventually the correct solution was found.
Sisophon2001
Posts: 1704
Joined: May 27, 2005 6:34
Location: Cambodia, Thailand, Lao, Ireland etc.
Contact:

Postby Sisophon2001 » Nov 07, 2011 13:22

In my sudoku solver I take a completed puzzle and remove random numbers one by one to see if it is solvable, and grade the results by degree of difficulty in solving. All valid puzzles are solvable quickly easily by brute force, so you need to program human methods to grade a puzzle.

This is the same technique human puzzle makers use. Japanese puzzles are often symmetric, so they adapt the technique to remove two numbers at a time.

Garvan
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Nov 07, 2011 21:59

BasicScience wrote:What is the method behind the alorithm used to find a solution? Code was a bit dense to figure it out from there.

I entered a "beware challenging" sudoku from the Will Shortz book. It took 5 min 55 sec to solve, but eventually the correct solution was found.


I use brute force to solve.
This method should solve all solvable sudokus, but it takes time now and then.
It would be much quicker if I didn't show the solution unravelling in the small screen, but who wants an empty screen to boggle at?
Phase 1:
Gets 8 of the 9 3x3 boxes to follow the rules by random filling.
Phase 2:
Assumes at least 2 of these boxes are correct, and checks every pair in turn. It randomly fills in the others.
Phase 3:
(if phase 2 fails), assumes that maybe one of these boxes is correct, and checks each box twice.
If no solution yet, then back to start.

It is not mathematical.
Thanks for trying a stinker.
It would be easily tweaked to play a game since just pressing solve straight away produces a complete sudoku, then 20 or so of these numbers could be held, and the rest could be filled in with mouse droppings.
badidea
Posts: 1897
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Sudoku Solver (re-done)

Postby badidea » Aug 10, 2014 14:44

Made one solver myself yesterday. Tested with 2 sudokus only:

Code: Select all

'-------------------------------------------------------------------------------

#define ISOPEN 1
#define ISCLOSED 0

type elem_type
   dim as integer sol 'solution
   dim as integer opt(1 to 9) 'option
end type

'-------------------------------------------------------------------------------

type sudoku_type
   dim as elem_type elem(0 to 8, 0 to 8)
   declare sub init()
   declare sub show(xpos as integer, ypos as integer)
   declare sub showOptions(xi as integer, yi as integer, xpos as integer, ypos as integer)
   declare function exclude(xElem as integer, yElem as integer) as integer
   declare function checkObvious() as integer
   declare function noBrainer() as integer
   declare function oneSolutionOnly() as integer
   declare function checkSolved() as integer
end type

sub sudoku_type.showOptions(xi as integer, yi as integer, xpos as integer, ypos as integer)
   dim as integer i
   locate ypos, xpos
   print "Elem:"; xi; yi; "   ";
   locate ypos+1, xpos
   print "Solution: "; elem(xi, yi).sol; "   ";
   for i = 1 to 9
      locate ypos+1+i, xpos
      print "Option"; i; ":"; elem(xi, yi).opt(i); "   ";
   next
end sub

sub sudoku_type.init()
   dim as integer xi, yi, i, value
   for yi = 0 to 8
      for xi = 0 to 8
         read value
         elem(xi, yi).sol = value
         if (value = 0) then
            'set all options open
            for i = 1 to 9
               elem(xi, yi).opt(i) = ISOPEN
            next
         else
            'set all options closed, except the solution
            for i = 1 to 9
               elem(xi, yi).opt(i) = ISCLOSED
            next
            elem(xi, yi).opt(value) = ISOPEN
         end if
      next
      print
   next
end sub

sub sudoku_type.show(xpos as integer, ypos as integer)
   dim as integer xi, yi
   'x index
   for xi = 0 to 8
      locate ypos + 0, xpos + 4 + xi * 2 + xi \ 3
      print str(xi);
   next
   'y index
   for yi = 0 to 8
      locate ypos + 2 + yi + yi \ 3, xpos + 0
      print str(yi);
   next
   'show values
   for yi = 0 to 8
      for xi = 0 to 8
         locate ypos + 2 + yi + yi \ 3, xpos + 4 + xi * 2 + xi \ 3
         if elem(xi, yi).sol = 0 then
            print ".";
         else
            print str(elem(xi, yi).sol);
         end if
      next
      print
   next
end sub

'excluse the obvious, eliminate open options
function sudoku_type.exclude(xElem as integer, yElem as integer) as integer
   dim as integer xi, yi, xSqr, ySqr
   dim as integer value, updates = 0
   value = elem(xElem, yElem).sol
   'do row
   yi = yElem
   for xi = 0 to 8
      if (elem(xi, yi).opt(value) = ISOPEN) then
         elem(xi, yi).opt(value) = ISCLOSED
         updates += 1
      end if
   next
   'do column
   xi = xElem
   for yi = 0 to 8
      if (elem(xi, yi).opt(value) = ISOPEN) then
         elem(xi, yi).opt(value) = ISCLOSED
         updates += 1
      end if
   next
   'do square
   xSqr = (xElem \ 3) * 3
   ySqr = (yElem \ 3) * 3
   for xi = xSqr to xSqr + 2
      for yi = ySqr to ySqr+2
         if (elem(xi, yi).opt(value) = ISOPEN) then
            elem(xi, yi).opt(value) = ISCLOSED
            updates += 1
         end if
      next
   next
   return updates
end function

function sudoku_type.checkObvious() as integer
   dim as integer xi, yi, value, updates = 0
   dim as integer xi2, yi2
   'loop all elements
   for yi = 0 to 8
      for xi = 0 to 8
         if (elem(xi, yi).sol <> 0) then
            updates += exclude(xi, yi)
         end if
      next
   next
   return updates
end function

'only 1 option left for element, then set solution
function sudoku_type.noBrainer() as integer
   dim as integer xi, yi, oi
   dim as integer numOpen, valOpen, updates = 0
   'loop all elements
   for yi = 0 to 8
      for xi = 0 to 8
         'check unsolved elements
         if (elem(xi, yi).sol = 0) then
            numOpen = 0
            'loop options
            for oi = 1 to 9
               if (elem(xi, yi).opt(oi) = ISOPEN) then
                  valOpen = oi
                  numOpen += 1
               end if
            next
            if (numOpen = 1) then
               elem(xi, yi).sol = valOpen
               updates += 1
            end if
         end if
      next
   next
   return updates
end function

'only 1 option left in col/row/sqr for a number,
'set setsolution, close other options for element
function sudoku_type.oneSolutionOnly() as integer
   dim as integer xi, yi, oi, xElem, yElem, xSqr, ySqr
   dim as integer value, numOpen, updates = 0
   for value = 1 to 9
      '~ 'loop rows
      for yi = 0 to 8
         numOpen = 0
         'check row for occurences of a specific value
         for xi = 0 to 8
            if (elem(xi, yi).opt(value) = ISOPEN) then
               numOpen += 1
               xElem = xi
            end if
         next
         if (numOpen = 1) then
            elem(xElem, yi).sol = value
            for oi = 1 to 9
               if (oi <> value) then elem(xElem, yi).opt(oi) = ISCLOSED
            next
            updates += 1
            'print "Row:"; xElem; yi; value
         end if
      next
      'loop columns
      for xi = 0 to 8
         numOpen = 0
         'check column for occurences of a specific value
         for yi = 0 to 8
            if (elem(xi, yi).opt(value) = ISOPEN) then
               numOpen += 1
               yElem = yi
            end if
         next
         if (numOpen = 1) then
            elem(xi, yElem).sol = value
            for oi = 1 to 9
               if (oi <> value) then elem(xi, yElem).opt(oi) = ISCLOSED
            next
            updates += 1
            'print "Col:"; xi; yElem; value
         end if
      next
      '~ 'loop squares
      for ySqr = 0 to 8 step 3
         for xSqr = 0 to 8 step 3
            numOpen = 0
            'check square for occurences of a specific value
            for xi = xSqr to xSqr + 2
               for yi = ySqr to ySqr + 2
                  if (elem(xi, yi).opt(value) = ISOPEN) then
                     numOpen += 1
                     xElem = xi
                     yElem = yi
                  end if
               next
            next
            if (numOpen = 1) then
               elem(xElem, yElem).sol = value
               for oi = 1 to 9
                  if (oi <> value) then elem(xElem, yElem).opt(oi) = ISCLOSED
               next
               updates += 1
               'print "Sqr:"; xElem; yElem; value
            end if
         next
      next
   next
   return updates
end function

function sudoku_type.checkSolved() as integer
   dim as integer xi, yi, i
   dim as integer value, solCount(1 to 9)
   'loop all cells
   for yi = 0 to 8
      for xi = 0 to 8
         value = elem(xi, yi).sol
         if (value <> 0) then solCount(value) += 1
      next
   next
   'loop solution counts
   for i = 1 to 9
      if (solCount(i) <> 9) then return 0
   next
   return 1
end function

'-------------------------------------------------------------------------------

dim as sudoku_type s
dim as integer updates = 1

s.init()
s.show(25, 5)

while inkey() <> "": wend 'clear key buffer
while (updates > 0)
   updates = s.oneSolutionOnly()
   locate 1,1: print "oneSolutionOnly    "
   sleep 500
   updates += s.checkObvious()
   locate 1,1: print "checkObvious       "
   sleep 500
   updates += s.noBrainer()
   locate 1,1: print "noBrainer           "
   sleep 500
   locate 1,1: print "updates:"; updates; "          "
   sleep 500
   s.show(25, 5)
wend
if (s.checkSolved() = 1) then
   locate 1,1: print "Ok, Solved.          "
else
   locate 1,1: print "Doh, not solved.          "
end if
print "End.               "
's.showOptions(5, 7, 50, 3)

while inkey() = "": wend
end

'-------------------------------------------------------------------------------

'Sudoku #1

'data 2, 8, 0,  0, 9, 7,  3, 0, 0
'data 4, 0, 7,  0, 3, 0,  8, 0, 0
'data 0, 3, 5,  0, 0, 8,  0, 0, 6

'data 0, 0, 0,  0, 1, 3,  0, 8, 0
'data 8, 0, 1,  0, 0, 0,  5, 0, 7
'data 0, 5, 0,  7, 8, 0,  0, 0, 0

'data 3, 0, 0,  8, 0, 0,  7, 2, 0
'data 0, 0, 8,  0, 2, 0,  4, 0, 3
'data 0, 0, 4,  3, 7, 0,  0, 5, 8

'Sudoku #2

data 0, 7, 0,  3, 0, 5,  4, 0, 0
data 0, 0, 6,  1, 0, 0,  0, 7, 0
data 0, 5, 8,  0, 9, 0,  0, 1, 3

data 0, 0, 3,  0, 0, 0,  7, 0, 0
data 0, 9, 0,  0, 0, 0,  0, 0, 0
data 0, 0, 0,  2, 1, 0,  3, 0, 0

data 0, 0, 0,  4, 0, 0,  0, 0, 7
data 6, 8, 0,  0, 7, 0,  0, 0, 0
data 4, 1, 0,  5, 0, 8,  0, 0, 0

'Sudoku #3

'data , , ,  , , ,  , ,
'data , , ,  , , ,  , ,
'data , , ,  , , ,  , ,

'data , , ,  , , ,  , ,
'data , , ,  , , ,  , ,
'data , , ,  , , ,  , ,

'data , , ,  , , ,  , ,
'data , , ,  , , ,  , ,
'data , , ,  , , ,  , ,

Note to self:
Why? Why did I make a sudoku solver while I have so many other programming projects to finish or start with?
Oh, I know why. Because there was this newspaper in front of me during my 50 minute train ride and I couldn't solve this sudoku in this time. So I spend another 4 hours or so on this solver!? Done with sudokus for now.
badidea
Posts: 1897
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Sudoku Solver (re-done)

Postby badidea » Aug 12, 2014 19:31

Mine does not solve 'hard' sudokus. E.g., this one:

Code: Select all

data 8, 0, 0,  7, 0, 0,  0, 0, 3
data 0, 7, 0,  9, 0, 0,  8, 0, 0
data 0, 0, 0,  8, 0, 6,  0, 1, 0

data 5, 0, 2,  3, 0, 0,  4, 6, 0
data 0, 9, 0,  0, 0, 0,  0, 3, 0
data 0, 6, 4,  0, 0, 2,  1, 0, 9

data 0, 5, 0,  6, 0, 8,  0, 0, 0
data 0, 0, 1,  0, 0, 5,  0, 4, 0
data 6, 0, 0,  0, 0, 7,  0, 0, 5

More coding to do. Also the checkSolved() should be improved.
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Sudoku Solver (re-done)

Postby dodicat » Aug 12, 2014 20:58

Thank you for your solver Badidea, your solver is pretty neat and not too many lines of code.
The solution for your stinker is:
8 2 9 7 1 4 6 5 3
1 7 6 9 5 3 8 2 4
4 3 5 8 2 6 9 1 7
5 1 2 3 7 9 4 6 8
7 9 8 4 6 1 5 3 2
3 6 4 5 8 2 1 7 9
2 5 7 6 4 8 3 9 1
9 8 1 2 3 5 7 4 6
6 4 3 1 9 7 2 8 5

It took 5.8 seconds with my one.
badidea
Posts: 1897
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Sudoku Solver (re-done)

Postby badidea » Aug 17, 2014 0:19

No improvements on the solving part yet, although I have some ideas, but a more pleasant graphical display implemented.
The small green squares indicate which solutions are still open.

Code: Select all

const as integer xScrSize = 800, yScrSize = 600

'--------------------------- line_char_type ------------------------------------

const as integer maxLineCharPoints = 16

type line_char_type
   dim as integer numLines
   dim as integer x1(maxLineCharPoints-1)
   dim as integer y1(maxLineCharPoints-1)
   dim as integer x2(maxLineCharPoints-1)
   dim as integer y2(maxLineCharPoints-1)
   declare sub init()
   declare sub printxy(x as integer, y as integer, scale as single, colour as integer, thickness as integer)
end type

sub line_char_type.init()
   dim as integer j
   read numLines
   for j = 0 to numLines-1
      read x1(j), y1(j), x2(j), y2(j)
   next
end sub

sub line_char_type.printxy(x as integer, y as integer, scale as single, colour as integer, thickness as integer)
   dim as integer j, nx1, ny1, nx2, ny2
   dim as integer xi, yi
   for j = 0 to numLines-1
      nx1 = x + (x1(j) * scale)
      ny1 = y + (y1(j) * scale)
      nx2 = x + (x2(j) * scale)
      ny2 = y + (y2(j) * scale)
      for xi = 0 to thickness
         for yi = 0 to thickness
            line (nx1+xi, ny1+yi)-(nx2+xi, ny2+yi), colour
         next
      next
   next
end sub

'--------------------------- line_chars_type -----------------------------------

const as integer numChar = 10

const as integer F_THIN = 0
const as integer F_NORMAL = 1
const as integer F_BOLD = 2

type line_chars_type
   dim as line_char_type char(numChar-1)
   dim as integer thickness = 0
   dim as integer colour = &h00ffffff
   dim as integer scale = 1
   declare sub init()
   declare sub setProperties(newScale as integer, newThickness as integer, newColour as integer)
   declare sub printxy(x as integer, y as integer, charNum as integer)
end type

sub line_chars_type.init()
   dim as integer i, j
   for i = 0 to numChar-1
      char(i).init()
   next
end sub

sub line_chars_type.setProperties(newScale as integer, newThickness as integer, newColour as integer)
   scale = newScale
   thickness = newThickness
   colour = newColour
end sub

sub line_chars_type.printxy(x as integer, y as integer, charNum as integer)
   char(charNum).printxy(x, y, scale, colour, thickness)
end sub

'--------------------------- elem_type -----------------------------------------

#define ISOPEN 1
#define ISCLOSED 0

type elem_type
   dim as integer sol 'solution
   dim as integer opt(1 to 9) 'option
end type

'--------------------------- sudoku_type ---------------------------------------

type sudoku_type
   dim as elem_type elem(0 to 8, 0 to 8)
   dim as line_chars_type lc
   declare sub init()
   declare sub showGrap()
   declare sub showText(xpos as integer, ypos as integer)
   declare sub showOptions(xi as integer, yi as integer, xpos as integer, ypos as integer)
   declare function exclude(xElem as integer, yElem as integer) as integer
   declare function checkObvious() as integer
   declare function noBrainer() as integer
   declare function oneSolutionOnly() as integer
   declare function checkSolved() as integer
end type

sub sudoku_type.init()
   dim as integer xi, yi, i, value
   for yi = 0 to 8
      for xi = 0 to 8
         read value
         elem(xi, yi).sol = value
         if (value = 0) then
            'set all options open
            for i = 1 to 9
               elem(xi, yi).opt(i) = ISOPEN
            next
         else
            'set all options closed, except the solution
            for i = 1 to 9
               elem(xi, yi).opt(i) = ISCLOSED
            next
            elem(xi, yi).opt(value) = ISOPEN
         end if
      next
      print
   next
   lc.init() 'read font data
end sub

sub sudoku_type.showText(xpos as integer, ypos as integer)
   dim as integer xi, yi
   'x index
   for xi = 0 to 8
      locate ypos + 0, xpos + 4 + xi * 2 + xi \ 3
      print str(xi);
   next
   'y index
   for yi = 0 to 8
      locate ypos + 2 + yi + yi \ 3, xpos + 0
      print str(yi);
   next
   'show values
   for yi = 0 to 8
      for xi = 0 to 8
         locate ypos + 2 + yi + yi \ 3, xpos + 4 + xi * 2 + xi \ 3
         if (elem(xi, yi).sol = 0) then
            print ".";
         else
            print str(elem(xi, yi).sol);
         end if
      next
      print
   next
end sub

sub sudoku_type.showGrap()
   dim as integer xi, yi, x, y, xi2, yi2, i, colour
   dim as integer xCellSize = 49, yCellSize = 49
   dim as integer xOffset = (xScrSize - xCellSize * 9) \ 2
   dim as integer yOffset = (yScrSize - yCellSize * 9) \ 2
   lc.setProperties(3, F_NORMAL, &h00ffff99)
   'line (0, 0) - (xScrSize - 1, yScrSize - 1), &h00ffffff, bf
   'draw squares
   for yi = 0 to 8 step 3
      for xi = 0 to 8 step 3
         x = xOffset + xi * xCellSize - 1
         y = yOffset + yi * yCellSize - 1
         line(x, y)-step(xCellSize * 3, yCellSize * 3), &h00ffffff, b
      next
   next
   'draw cells
   for yi = 0 to 8
      for xi = 0 to 8
         x = xOffset + xi * xCellSize
         y = yOffset + yi * yCellSize
         'show options
         i = 1
         for yi2 = 0 to 2
            for xi2 = 0 to 2
               if (elem(xi, yi).opt(i) = ISOPEN) then
                  colour = &h00004400
               else
                  colour = &h00440000
               end if
               line(x + xi2 * 15 + 2, y + yi2 * 15 + 2)-step(xCellSize\3 - 3, yCellSize\3 - 3), colour, bf
               i += 1
            next
         next
         'small square
         line(x, y)-step(xCellSize - 2, yCellSize - 2), &h00404040, b
         'show value
         if (elem(xi, yi).sol <> 0) then
            lc.printxy(x + 17, y + 13, elem(xi, yi).sol)
         end if
      next
   next
end sub

sub sudoku_type.showOptions(xi as integer, yi as integer, xpos as integer, ypos as integer)
   dim as integer i
   locate ypos, xpos
   print "Elem:"; xi; yi; "   ";
   locate ypos+1, xpos
   print "Solution: "; elem(xi, yi).sol; "   ";
   for i = 1 to 9
      locate ypos+1+i, xpos
      print "Option"; i; ":"; elem(xi, yi).opt(i); "   ";
   next
end sub

'excluse the obvious, eliminate open options
' E.g.:
' Value of a cell is 2:
' - Disable all 2's in this row
' - Disable all 2's in this column
' - Disable all 2's in this square
' VALUES --> OPTIONS
function sudoku_type.exclude(xElem as integer, yElem as integer) as integer
   dim as integer xi, yi, xSqr, ySqr
   dim as integer value, updates = 0
   value = elem(xElem, yElem).sol
   'do row
   yi = yElem
   for xi = 0 to 8
      if (elem(xi, yi).opt(value) = ISOPEN) then
         elem(xi, yi).opt(value) = ISCLOSED
         updates += 1
      end if
   next
   'do column
   xi = xElem
   for yi = 0 to 8
      if (elem(xi, yi).opt(value) = ISOPEN) then
         elem(xi, yi).opt(value) = ISCLOSED
         updates += 1
      end if
   next
   'do square
   xSqr = (xElem \ 3) * 3
   ySqr = (yElem \ 3) * 3
   for xi = xSqr to xSqr + 2
      for yi = ySqr to ySqr+2
         if (elem(xi, yi).opt(value) = ISOPEN) then
            elem(xi, yi).opt(value) = ISCLOSED
            updates += 1
         end if
      next
   next
   return updates
end function

'loop all cells:
' - if cell has a non-zero value, launch exclude() function
' VALUES --> OPTIONS
function sudoku_type.checkObvious() as integer
   dim as integer xi, yi, value, updates = 0
   dim as integer xi2, yi2
   'loop all elements
   for yi = 0 to 8
      for xi = 0 to 8
         if (elem(xi, yi).sol <> 0) then
            updates += exclude(xi, yi)
         end if
      next
   next
   return updates
end function

'if only 1 option left for element, then set solution
'loop all cells, count number of open options
' OPTIONS --> VALUES
function sudoku_type.noBrainer() as integer
   dim as integer xi, yi, oi
   dim as integer numOpen, valOpen, updates = 0
   'loop all elements
   for yi = 0 to 8
      for xi = 0 to 8
         'check unsolved elements
         if (elem(xi, yi).sol = 0) then
            numOpen = 0
            'loop options
            for oi = 1 to 9
               if (elem(xi, yi).opt(oi) = ISOPEN) then
                  valOpen = oi
                  numOpen += 1
               end if
            next
            if (numOpen = 1) then
               elem(xi, yi).sol = valOpen
               updates += 1
            end if
         end if
      next
   next
   return updates
end function

'only 1 option left in col/row/sqr for a number,
'set setsolution, close other options for element
' OPTIONS --> VALUES, OPTIONS
function sudoku_type.oneSolutionOnly() as integer
   dim as integer xi, yi, oi, xElem, yElem, xSqr, ySqr
   dim as integer value, numOpen, updates = 0
   for value = 1 to 9
      '~ 'loop rows
      for yi = 0 to 8
         numOpen = 0
         'check row for occurences of a specific value
         for xi = 0 to 8
            if (elem(xi, yi).opt(value) = ISOPEN) then
               numOpen += 1
               xElem = xi
            end if
         next
         if (numOpen = 1) then
            elem(xElem, yi).sol = value
            for oi = 1 to 9
               if (oi <> value) then elem(xElem, yi).opt(oi) = ISCLOSED
            next
            updates += 1
            'print "Row:"; xElem; yi; value
         end if
      next
      'loop columns
      for xi = 0 to 8
         numOpen = 0
         'check column for occurences of a specific value
         for yi = 0 to 8
            if (elem(xi, yi).opt(value) = ISOPEN) then
               numOpen += 1
               yElem = yi
            end if
         next
         if (numOpen = 1) then
            elem(xi, yElem).sol = value
            for oi = 1 to 9
               if (oi <> value) then elem(xi, yElem).opt(oi) = ISCLOSED
            next
            updates += 1
            'print "Col:"; xi; yElem; value
         end if
      next
      '~ 'loop squares
      for ySqr = 0 to 8 step 3
         for xSqr = 0 to 8 step 3
            numOpen = 0
            'check square for occurences of a specific value
            for xi = xSqr to xSqr + 2
               for yi = ySqr to ySqr + 2
                  if (elem(xi, yi).opt(value) = ISOPEN) then
                     numOpen += 1
                     xElem = xi
                     yElem = yi
                  end if
               next
            next
            if (numOpen = 1) then
               elem(xElem, yElem).sol = value
               for oi = 1 to 9
                  if (oi <> value) then elem(xElem, yElem).opt(oi) = ISCLOSED
               next
               updates += 1
               'print "Sqr:"; xElem; yElem; value
            end if
         next
      next
   next
   return updates
end function

function sudoku_type.checkSolved() as integer
   dim as integer xi, yi, i, sum
   dim as integer value, solCount(1 to 9)
   'loop all cells, count occurence
   for yi = 0 to 8
      for xi = 0 to 8
         value = elem(xi, yi).sol
         if (value <> 0) then solCount(value) += 1
      next
   next
   'loop solution counts
   for i = 1 to 9
      if (solCount(i) <> 9) then return 0
   next
   'check sum rows
   for yi = 0 to 8
      sum = 0
      for xi = 0 to 8
         sum += elem(xi, yi).sol
      next
      if (sum <> 45) then return 0
   next
   'check sum columns
   for xi = 0 to 8
      sum = 0
      for yi = 0 to 8
         sum += elem(xi, yi).sol
      next
      if (sum <> 45) then return 0
   next
   return 1
end function

'--------------------------- Main loop -----------------------------------------

dim as sudoku_type s
dim as integer updates = 1, count = 0

screenres xScrSize, yScrSize, 32

s.init()
s.showGrap()

while inkey() <> "": wend 'clear key buffer
while (updates > 0)
   updates = s.oneSolutionOnly()
   locate 1,1: print "oneSolutionOnly    "
   sleep 100
   updates += s.checkObvious()
   locate 1,1: print "checkObvious       "
   sleep 100
   updates += s.noBrainer()
   'locate 1,1: print "noBrainer           "
   sleep 100
   locate 1,1: print "updates:"; updates; "          "
   sleep 100
   s.showGrap()
   count += 1
wend
print "count:"; count
if (s.checkSolved() = 1) then
   locate 1,1: print "Ok, Solved.          "
else
   locate 1,1: print "Doh, not solved.          "
end if
print "End.               "
's.showOptions(5, 7, 50, 3)

while inkey() = "": wend
end

'-------------------------------------------------------------------------------

'Sudoku #1

'data 2, 8, 0,  0, 9, 7,  3, 0, 0
'data 4, 0, 7,  0, 3, 0,  8, 0, 0
'data 0, 3, 5,  0, 0, 8,  0, 0, 6

'data 0, 0, 0,  0, 1, 3,  0, 8, 0
'data 8, 0, 1,  0, 0, 0,  5, 0, 7
'data 0, 5, 0,  7, 8, 0,  0, 0, 0

'data 3, 0, 0,  8, 0, 0,  7, 2, 0
'data 0, 0, 8,  0, 2, 0,  4, 0, 3
'data 0, 0, 4,  3, 7, 0,  0, 5, 8

'Sudoku #2

'data 0, 7, 0,  3, 0, 5,  4, 0, 0
'data 0, 0, 6,  1, 0, 0,  0, 7, 0
'data 0, 5, 8,  0, 9, 0,  0, 1, 3

'data 0, 0, 3,  0, 0, 0,  7, 0, 0
'data 0, 9, 0,  0, 0, 0,  0, 0, 0
'data 0, 0, 0,  2, 1, 0,  3, 0, 0

'data 0, 0, 0,  4, 0, 0,  0, 0, 7
'data 6, 8, 0,  0, 7, 0,  0, 0, 0
'data 4, 1, 0,  5, 0, 8,  0, 0, 0

'Sudoku #3 HARD

data 8, 0, 0,  7, 0, 0,  0, 0, 3
data 0, 7, 0,  9, 0, 0,  8, 0, 0
data 0, 0, 0,  8, 0, 6,  0, 1, 0

data 5, 0, 2,  3, 0, 0,  4, 6, 0
data 0, 9, 0,  0, 0, 0,  0, 3, 0
data 0, 6, 4,  0, 0, 2,  1, 0, 9

data 0, 5, 0,  6, 0, 8,  0, 0, 0
data 0, 0, 1,  0, 0, 5,  0, 4, 0
data 6, 0, 0,  0, 0, 7,  0, 0, 5

'Sudoku #4 BAD

'data 8, 4, 5,  7, 1, 0,  0, 0, 3
'data 0, 7, 0,  9, 0, 0,  8, 0, 0
'data 0, 0, 9,  8, 0, 6,  6, 1, 7

'data 5, 0, 2,  3, 0, 0,  4, 6, 0
'data 0, 9, 0,  0, 0, 0,  0, 3, 0
'data 0, 6, 4,  0, 0, 2,  1, 0, 9

'data 4, 5, 0,  6, 0, 8,  0, 0, 0
'data 0, 0, 1,  0, 0, 5,  0, 4, 0
'data 6, 0, 0,  1, 0, 7,  0, 0, 5

' Number: 0
data 8
data 0, 1, 1, 0
data 1, 0, 3, 0
data 3, 0, 4, 1
data 4, 1, 4, 5
data 4, 5, 3, 6
data 3, 6, 1, 6
data 1, 6, 0, 5
data 0, 5, 0, 1
' Number: 1
data 3
data 1, 6, 3, 6
data 2, 6, 2, 0
data 2, 0, 1, 1
' Number: 2
data 9
data 0, 1, 1, 0
data 1, 0, 3, 0
data 3, 0, 4, 1
data 0, 6, 4, 6
data 3, 4, 4, 3
data 4, 3, 4, 1
data 0, 6, 0, 5
data 1, 4, 3, 4
data 1, 4, 0, 5
' Number: 3
data 11
data 0, 1, 1, 0
data 1, 0, 3, 0
data 3, 0, 4, 1
data 4, 1, 4, 2
data 4, 2, 3, 3
data 3, 3, 4, 4
data 4, 4, 4, 5
data 4, 5, 3, 6
data 3, 6, 1, 6
data 1, 6, 0, 5
data 3, 3, 1, 3
' Number: 4
data 3
data 2, 0, 0, 4
data 0, 4, 4, 4
data 3, 3, 3, 6
' Number: 5
data 9
data 1, 2, 3, 2
data 3, 2, 4, 3
data 4, 3, 4, 5
data 4, 5, 3, 6
data 3, 6, 1, 6
data 1, 6, 0, 5
data 0, 0, 4, 0
data 0, 0, 0, 1
data 1, 2, 0, 1
' Number: 6
data 11
data 1, 6, 3, 6
data 3, 6, 4, 5
data 1, 6, 0, 5
data 0, 5, 0, 1
data 1, 0, 3, 0
data 4, 5, 4, 3
data 4, 3, 3, 2
data 3, 2, 1, 2
data 1, 2, 0, 3
data 0, 1, 1, 0
data 3, 0, 4, 1
' Number: 7
data 3
data 0, 0, 4, 0
data 4, 0, 1, 6
data 1, 3, 4, 3
' Number: 8
data 15
data 1, 0, 3, 0
data 3, 0, 4, 1
data 1, 0, 0, 1
data 1, 6, 3, 6
data 3, 6, 4, 5
data 1, 6, 0, 5
data 0, 5, 0, 4
data 0, 1, 0, 2
data 4, 1, 4, 2
data 4, 4, 4, 5
data 4, 4, 3, 3
data 3, 3, 4, 2
data 3, 3, 1, 3
data 1, 3, 0, 2
data 1, 3, 0, 4
' Number: 9
data 11
data 0, 1, 1, 0
data 1, 0, 3, 0
data 3, 0, 4, 1
data 4, 1, 4, 5
data 1, 6, 3, 6
data 3, 6, 4, 5
data 1, 6, 0, 5
data 0, 3, 0, 1
data 0, 3, 1, 4
data 1, 4, 3, 4
data 3, 4, 4, 3
badidea
Posts: 1897
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Sudoku Solver (re-done)

Postby badidea » Aug 20, 2014 22:34

No solution yet for this hard one, from my program. When my solver stops, a the bottom-left square 2 numbers are left open (2 and 4). When placing them correctly, the sudoku is easily solved. But when placing them incorrectly, it seems to take a lot of steps to discover that the wrong choice was made. I can solve it until this point:

Image

The last 2 numbers are impossible.

I'll continue to look for a way to discover quickly that the wrong choice was made (or better, is to be made). I consider brute force cheating :-)

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 4 guests