Board Logo
« Solve SUDOKU with recursivity. »

Welcome Guest. Please Login or Register.
Jan 21st, 2018, 03:00am


Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Please use the forums Search feature before asking.
Please post code using the code box described in Format Your Messages.
This will keep indentation, separate it better form the message and prevent gibberish.
If the code is too long for one post or additional files are needed, upload a ZIP archive to the Just BASIC Files Archive Site.

« Previous Topic | Next Topic »
Pages: 1 2 3  Notify Send Topic Print
 veryhotthread  Author  Topic: Solve SUDOKU with recursivity.  (Read 5882 times)
cassiope01
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 669
xx Solve SUDOKU with recursivity.
« Thread started on: Nov 19th, 2011, 12:20pm »

Following this TyCamden's thread, I thought writing a program to solve Sudoku.
I found some examples on the web in other languages ​​using recursivity...
So I adapted them in JB.
And that's it.

Recursivity is especially interested me a lot ...

Code:
   ' Simple GUI for SUDOKU, written by cassiope01  ( 11/18/2011 )
  ' Test recurcivity to solve SUDOKU...

    nomainwin

    mois$ = "Jan Fév Mar Avr Mai Jun Jui Aou Sep Oct Nov Déc"
    today$ = date$("mm/dd/yyyy")
    j = date$(today$)
    jsem$ = word$("Mar Mer Jeu x Ven Sam x Dim Lun",int((j/7-int(j/7))*10)+1)
    date$ = jsem$+" "+mid$(today$,4,2)+" "+word$(mois$, val(today$))+"   "+left$(time$(),5)'right$(today$,4)

    dim cell(9,9)
    global sc, offset, cx, cy, bckcolor$, selection, comp.tests
    sc = 60       'size of a cell, you can try to change...!
    offset = 20   'distance from the edge
    bckcolor$ = "yellow"  'background color

    WindowWidth = 9 * sc + 2 * offset + offset/2
    WindowHeight = WindowWidth + offset + offset/4
    UpperLeftX = (DisplayWidth-WindowWidth) / 3
    UpperLeftY = (DisplayHeight-WindowHeight) / 2

    open "    S U D O K U ..."+space$(20)+date$ for graphics_nf_nsb as #g  'window_nf
    #g "trapclose quit"
    #g "down"

    call makeSprite
    call drawcube

    #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
    #g "background bckgrd"
    #g "addsprite square square"
    #g "font courrier_new ";sc/2

    #g "setfocus"
    #g "when characterInput player"
    #g "when leftButtonDown Clic"
    #g "when rightButtonDown Give"

    WAIT

    sub player handle$, inkey$       'keyboard input    ( 0 to erase this cell)
        #g "spritexy square -100 0"
        #g "drawsprites"
        select case
        case instr("0123456789",upper$(left$(inkey$,1)))>0 and selection = 1
            cell(cx,cy) = val(upper$(left$(inkey$,1)))
            #g "backcolor ";bckcolor$
            if cell(cx,cy) > 0 then
                #g "place ";offset+(cx-1)*sc+sc/5+sc/8;" ";offset+(cy-1)*sc+sc/2+sc/4;";|";cell(cx,cy)
            else
                #g "color ";bckcolor$
                #g "place ";offset+(cx-1)*sc+5;" ";offset+(cy-1)*sc+5;";boxfilled ";offset+(cx-1)*sc+sc-3;" ";offset+(cy-1)*sc+sc-3 'erase
                #g "color black"
            end if
            #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
            #g "background bckgrd"
        case upper$(left$(inkey$,1)) = "S"   'solve this sudoku
            #g "backcolor ";bckcolor$;"; color black"
            #g "font courrier_new 10"
            #g "place 50 ";WindowHeight-35;";|Thinking...."
            #g "font courrier_new ";sc/2
            deb = time$("ms")
            comp.tests = 0
            call resolve
            call affgrille
            res = time$("ms")-deb
            sec = int(res/1000)
            if sec > 0 then
                if sec > 60 then
                    minute = int(sec/60)
                    sec = sec-minute*60
                    if minute then
                        res$ = str$(minute)+"  min  "+str$(sec)+"  sec  "+str$(res-sec*1000)+"  ms."
                    end if
                 else
                    res$ = str$(sec)+"  sec  "+str$(res-sec*1000)+"  ms.         "
                 end if
             else
                res$ = str$(res)+"  ms.                       "
             end if
            #g "font courrier_new 10"
            #g "place 50 ";WindowHeight-35;";|";res$
            #g "font courrier_new ";sc/2
        case upper$(left$(inkey$,1)) = "N"   ' reinit
            redim cell(9,9)
            call drawcube
            #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
            #g "background bckgrd"
        end select
        #g "flush; discard"
        selection = 0
    end sub

    sub Give handle$, mousex, mousey   'to give a good number
        #g "spritexy square -100 0"
        #g "drawsprites"
        cx = int((mousex-offset)/sc)+1
        cy = int((mousey-offset)/sc)+1
        if cx > 9 then cx = 9
        if cy > 9 then cy = 9
        if cell(cx,cy) = 0 then
            cell(cx,cy) = control(cx,cy)   'a good number with rnd() 1 - 9
            if cell(cx,cy) > 0 then
                #g "backcolor ";bckcolor$
                #g "place ";offset+(cx-1)*sc+sc/5+sc/8;" ";offset+(cy-1)*sc+sc/2+sc/4;";|";cell(cx,cy)
                #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
                #g "background bckgrd"
                #g "flush; discard"
            end if
        end if
        selection = 0
    end sub

    sub Clic handle$, mousex, mousey   'to place the sprite to show the selection
        cx = int((mousex-offset)/sc)+1
        cy = int((mousey-offset)/sc)+1
        if cx > 9 then cx = 9
        if cy > 9 then cy = 9
        #g "spritexy square -100 0"
        #g "drawsprites"
        #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
        #g "background bckgrd"
        #g "spritexy square ";offset+(cx-1)*sc-2;" ";offset+(cy-1)*sc-2
        #g "drawsprites"
        selection = 1
    end sub

    Function control(x,y)  'to never give a wrong number...
        DO
            control = int(rnd(0)*9)+1
            cpt=cpt+1  'to avoid crash...
        LOOP UNTIL ok(control,x,y)>0 or cpt > 50
        if cpt > 50 then control = 0  'bug...!
    end function


    '**************************************************************************************************

    sub resolve
        for yy = 1 to 9
            for xx = 1 to 9
                if cell(xx,yy) = 0 then
                    for nb = 1 to 9
                        if ok(nb,xx,yy) then
                            nbre.tamp = cell(xx,yy)
                            cell(xx,yy) = nb
                            comp.tests = comp.tests + 1
                           ' #g "font courrier_new 10"
                           ' #g "place 50 ";WindowHeight-35;";|";comp.tests;"         "
                           ' #g "font courrier_new ";sc/2
                            call resolve
                            scan
                            if grille.finie() then exit sub
                            'if grille.finie() then call affgrille :#g "when characterInput player"
                            cell(xx,yy) = nbre.tamp
                        end if
                    next
                    exit sub
                end if
            next
        next
    end sub

    Function grille.finie()  'grid finished ?
        grille.finie = 1
        for yy = 1 to 9
            for xx = 1 to 9
                if cell(xx,yy) = 0 then
                    grille.finie = 0 :exit function
                end if
            next
        next
    end function

    Function ok(nbre,x,y)  'is nbre is possible in cell(x,y) ?
        string$ = "" :ok = 1
        for c = 1 to 9
            string$ = string$+" "+str$(c)+str$(y)+" "
        next
        for c = 1 to 9
            string$ = string$+" "+str$(x)+str$(c)+" "
        next
        dx = 1*(x<4)+4*(x>3 and x<7)+7*(x>6)  'corner up/left of one of the nine big square
        dy = 1*(y<4)+4*(y>3 and y<7)+7*(y>6)
        for iy = 0 to 2
            for ix = 0 to 2
                string$ = string$+" "+str$(dx+ix)+str$(dy+iy)+" "
            next
        next
        DO
            for cp = 1 to 27
                cpx = val(left$(word$(string$,cp),1))
                cpy = val(right$(word$(string$,cp),1))
                if cell(cpx,cpy) = nbre then ok = 0 :exit function
            next
        LOOP UNTIL cp = 28
    end function

    '**************************************************************************************************

    sub affgrille
        for y = 1 to 9
            for x = 1 to 9
                if cell(x,y) > 0 then
                    #g "backcolor ";bckcolor$
                    #g "place ";offset+(x-1)*sc+sc/5+sc/8;" ";offset+(y-1)*sc+sc/2+sc/4;";|";cell(x,y)
                else
                    #g "color ";bckcolor$
                    #g "place ";offset+(x-1)*sc+5;" ";offset+(y-1)*sc+5;";boxfilled ";offset+(x-1)*sc+sc-3;" ";offset+(y-1)*sc+sc-3 'erase
                    #g "color black"
                end if
            next
        next
        #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
        #g "background bckgrd"
        #g "flush; discard"
    end sub

    sub drawcube
        #g "fill ";bckcolor$
        #g "backcolor black; color black"
        #g "size 1"
        for y = 1 to 9
            for x = 1 to 9
                #g "place ";offset+(x-1)*sc;" ";offset+(y-1)*sc
                #g "box ";offset+(x-1)*sc+sc;" ";offset+(y-1)*sc+sc
            next
        next
        #g "size 4" :scBig = 3 * sc
        for yy = 1 to 3
            for xx = 1 to 3
                #g "place ";offset+(xx-1)*scBig;" ";offset+(yy-1)*scBig
                #g "box ";offset+(xx-1)*scBig+scBig;" ";offset+(yy-1)*scBig+scBig
            next
        next
        #g "backcolor ";bckcolor$;"; color black"
        #g "font courrier_new 10"
        #g "place ";WindowWidth-140;" ";WindowHeight-35;";|N = New    S = Solve"
        #g "font courrier_new ";sc/2
    end sub

    sub makeSprite
        #g "size 5"
        #g "place 2 2"
        #g "box ";sc+2;" ";sc+2
        #g "backcolor black"
        #g "place 2 ";sc+2
        #g "boxfilled ";sc+2;" ";2*sc+2
        #g "color red"
        #g "place 2 ";sc+4
        #g "box ";sc+2;" ";2*sc+2
        #g "getbmp square 0 0 ";sc+4;" ";2*(sc+4)-4
        bmpsave "square" , "square.bmp"
    end sub

    sub quit handle$
        close #handle$
        END
    end sub 


it solve all solvable grid.

- input any number 1-9 after having selected the cell with the mouse.
- input "0" in a cell to erase it.
- right click generate a random number but... you can create an unsolvable grid...!
- tape "S" to solve the grid
- tape "N" to delete all.
« Last Edit: Nov 19th, 2011, 1:02pm by cassiope01 » User IP Logged

"It is better to mobilize its intelligence for stupid things, rather than mobilizing its stupidity for intelligent things."
jaba
Global Moderator
ImageImageImageImageImage


member is online

Avatar




PM

Gender: Male
Posts: 1049
xx Re: Solve SUDOKU with recursivity.
« Reply #1 on: Nov 19th, 2011, 2:17pm »

Very nice! I'm going to spend some time going over this code.

Everything is so fast... smiley
User IP Logged

JACK - Windows 8.1 64-bit; 2.5 GHz Intel i3 processor; 6.00 GB RAM;
NJames
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM


Posts: 661
xx Re: Solve SUDOKU with recursivity.
« Reply #2 on: Nov 19th, 2011, 2:58pm »

Wow. That's impressive.
User IP Logged

TyCamden
Global Moderator
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1431
xx Re: Solve SUDOKU with recursivity.
« Reply #3 on: Nov 19th, 2011, 4:05pm »

Yikes. This is a great program.

Mine is way way way longer, and I am no where near done yet. This is so elegant. I love it.

CRASH (sound of my program doing into the scrap heap)

smiley
User IP Logged

TyCamden

Please give credit if you use code I post, no need to ask for permission.


Just BASIC 1.01, Windows 7 Home Premium version (2009), AMD Athelon II 320 Dual-Core Processor 2.10 GHz - 4.00 GB RAM (3.75 usable) - 64-bit OS
TyCamden
Global Moderator
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1431
xx Re: Solve SUDOKU with recursivity.
« Reply #4 on: Nov 19th, 2011, 5:45pm »

on Nov 19th, 2011, 12:20pm, cassiope01 wrote:
Following this TyCamden's thread, I thought writing a program to solve Sudoku.
I found some examples on the web in other languages ​​using recursivity...
So I adapted them in JB.
And that's it.

Recursivity is especially interested me a lot ...

...(CODE)...

it solve all solvable grid.

- input any number 1-9 after having selected the cell with the mouse.
- input "0" in a cell to erase it.
- right click generate a random number but... you can create an unsolvable grid...!
- tape "S" to solve the grid
- tape "N" to delete all.



cassiope01,

I modified your program a little, since I prefer mouse only (no keystrokes).

Changes made as follows:

' changed background color from yellow to white
' variable called offset had value changed from 20 to 60
' changed the quit routine from a sub, to having a [branchLabel]
' added confirmation to the quit routine using the notice command
' added a QUIT button
' changed the 'solve' routine from a sub, to having a [branchLabel]
' added a SOLVE button and removed the "S" keypress
' changed the 'new' routine from a sub, to having a [branchLabel]
' added a NEW button and removed the "N" keypress
' removed the following line of code since it is obvious now what options the user has. ... #g "place ";WindowWidth-140;" ";WindowHeight-35;";|N = New S = Solve"
' changed the month displayed from French to English ( in variable mois$ )
' changed the weekday displayed from French to English ( in variable jsem$ )

(revised code to follow in another post)
User IP Logged

TyCamden

Please give credit if you use code I post, no need to ask for permission.


Just BASIC 1.01, Windows 7 Home Premium version (2009), AMD Athelon II 320 Dual-Core Processor 2.10 GHz - 4.00 GB RAM (3.75 usable) - 64-bit OS
TyCamden
Global Moderator
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1431
xx Re: Solve SUDOKU with recursivity.
« Reply #5 on: Nov 19th, 2011, 5:46pm »

PART 1 of code:

Code:
'  Sukoku solver program
'  version 2

'  written by cassiope01 on 18 Nov 2011
'  modified very slightly by TyCamden on 19 Nov 2011
'   v 2 changes include:
'         changed background color from yellow to white
'         variable called offset had value changed from 20 to 60
'         changed the quit routine from a sub, to having a [branchLabel]
'         added confirmation to the quit routine using the notice command
'         added a QUIT button
'         changed the 'solve' routine from a sub, to having a [branchLabel]
'         added a SOLVE button and removed the "S" keypress
'         changed the 'new' routine from a sub, to having a [branchLabel]
'         added a NEW button and removed the "N" keypress
'         removed the following line of code since it is obvious now what options the user has.
'            #g "place ";WindowWidth-140;" ";WindowHeight-35;";|N = New    S = Solve"
'         changed the month displayed from French to English ( in variable mois$ )
'         changed the weekday displayed from French to English ( in variable jsem$ )

    nomainwin

    mois$ = "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"
    today$ = date$("mm/dd/yyyy")
    j = date$(today$)
    jsem$ = word$("Tue Wed Thu x Fri Sat x Sun Mon",int((j/7-int(j/7))*10)+1)
    date$ = jsem$+" "+mid$(today$,4,2)+" "+word$(mois$, val(today$))+"   "+left$(time$(),5)'right$(today$,4)

    dim cell(9,9)
    global sc, offset, cx, cy, bckcolor$, selection, comp.tests
    sc = 60       'size of a cell, you can try to change...!
    offset = 60   'distance from the edge
    bckcolor$ = "white"  'background color

    WindowWidth = 9 * sc + 2 * offset + offset/2
    WindowHeight = WindowWidth + offset + offset/4
    UpperLeftX = (DisplayWidth-WindowWidth) / 3
    UpperLeftY = (DisplayHeight-WindowHeight) / 2

    button #g.solveButton, "Solve", [solvePressed], UL, 60, 620, 80, 40
    button #g.newButton, "New", [newPressed], UL, 180, 620, 80, 40
    button #g.quitButton, "Quit", [quitPressed], UL, 520, 620, 80, 40

    open "    S U D O K U ..."+space$(20)+date$ for graphics_nf_nsb as #g  'window_nf

    #g, "trapclose [quitPressed]"
    #g "down"

    call makeSprite
    call drawcube

    #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
    #g "background bckgrd"
    #g "addsprite square square"
    #g "font courrier_new ";sc/2

    #g "setfocus"
    #g "when characterInput player"
    #g "when leftButtonDown Clic"
    #g "when rightButtonDown Give"

[mainAction]
    'make sure #g has input focus
        #g, "setfocus"
        #g "when characterInput player"
        #g "when leftButtonDown Clic"
        #g "when rightButtonDown Give"
    'scan for events
        scan
    wait

[quitPressed]
    confirm "Do you want to quit ?"; quit$
    if quit$ = "no" then
        wait
    else
        close #g
        END
    end if

[solvePressed]
        #g "spritexy square -100 0"
        #g "drawsprites"
            #g "backcolor ";bckcolor$;"; color black"
            #g "font courrier_new 10"
            #g "place 50 ";WindowHeight-35;";|Thinking...."
            #g "font courrier_new ";sc/2
            deb = time$("ms")
            comp.tests = 0
            call resolve
            call affgrille
            res = time$("ms")-deb
            sec = int(res/1000)
            if sec > 0 then
                if sec > 60 then
                    minute = int(sec/60)
                    sec = sec-minute*60
                    if minute then
                        res$ = str$(minute)+"  min  "+str$(sec)+"  sec  "+str$(res-sec*1000)+"  ms."
                    end if
                 else
                    res$ = str$(sec)+"  sec  "+str$(res-sec*1000)+"  ms.         "
                 end if
             else
                res$ = str$(res)+"  ms.                       "
             end if
            #g "font courrier_new 10"
            #g "place 50 ";WindowHeight-35;";|";res$
            #g "font courrier_new ";sc/2
        #g "flush; discard"
        selection = 0
    goto [mainAction]

[newPressed]
        #g "spritexy square -100 0"
        #g "drawsprites"
            redim cell(9,9)
            call drawcube
            #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
            #g "background bckgrd"
        #g "flush; discard"
        selection = 0
    goto [mainAction] 

User IP Logged

TyCamden

Please give credit if you use code I post, no need to ask for permission.


Just BASIC 1.01, Windows 7 Home Premium version (2009), AMD Athelon II 320 Dual-Core Processor 2.10 GHz - 4.00 GB RAM (3.75 usable) - 64-bit OS
TyCamden
Global Moderator
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1431
xx Re: Solve SUDOKU with recursivity.
« Reply #6 on: Nov 19th, 2011, 5:48pm »

PART 2 of revised code

Code:
    sub player handle$, inkey$       'keyboard input    ( 0 to erase this cell)
        #g "spritexy square -100 0"
        #g "drawsprites"
        select case
        case instr("0123456789",upper$(left$(inkey$,1)))>0 and selection = 1
            cell(cx,cy) = val(upper$(left$(inkey$,1)))
            #g "backcolor ";bckcolor$
            if cell(cx,cy) > 0 then
                #g "place ";offset+(cx-1)*sc+sc/5+sc/8;" ";offset+(cy-1)*sc+sc/2+sc/4;";|";cell(cx,cy)
            else
                #g "color ";bckcolor$
                #g "place ";offset+(cx-1)*sc+5;" ";offset+(cy-1)*sc+5;";boxfilled ";offset+(cx-1)*sc+sc-3;" ";offset+(cy-1)*sc+sc-3 'erase
                #g "color black"
            end if
            #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
            #g "background bckgrd"
        end select
        #g "flush; discard"
        selection = 0
    end sub

    sub Give handle$, mousex, mousey   'to give a good number
        #g "spritexy square -100 0"
        #g "drawsprites"
        cx = int((mousex-offset)/sc)+1
        cy = int((mousey-offset)/sc)+1
        if cx > 9 then cx = 9
        if cy > 9 then cy = 9
        if cell(cx,cy) = 0 then
            cell(cx,cy) = control(cx,cy)   'a good number with rnd() 1 - 9
            if cell(cx,cy) > 0 then
                #g "backcolor ";bckcolor$
                #g "place ";offset+(cx-1)*sc+sc/5+sc/8;" ";offset+(cy-1)*sc+sc/2+sc/4;";|";cell(cx,cy)
                #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
                #g "background bckgrd"
                #g "flush; discard"
            end if
        end if
        selection = 0
    end sub

    sub Clic handle$, mousex, mousey   'to place the sprite to show the selection
        cx = int((mousex-offset)/sc)+1
        cy = int((mousey-offset)/sc)+1
        if cx > 9 then cx = 9
        if cy > 9 then cy = 9
        #g "spritexy square -100 0"
        #g "drawsprites"
        #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
        #g "background bckgrd"
        #g "spritexy square ";offset+(cx-1)*sc-2;" ";offset+(cy-1)*sc-2
        #g "drawsprites"
        selection = 1
    end sub

    Function control(x,y)  'to never give a wrong number...
        DO
            control = int(rnd(0)*9)+1
            cpt=cpt+1  'to avoid crash...
        LOOP UNTIL ok(control,x,y)>0 or cpt > 50
        if cpt > 50 then control = 0  'bug...!
    end function


    '**************************************************************************************************

    sub resolve
        for yy = 1 to 9
            for xx = 1 to 9
                if cell(xx,yy) = 0 then
                    for nb = 1 to 9
                        if ok(nb,xx,yy) then
                            nbre.tamp = cell(xx,yy)
                            cell(xx,yy) = nb
                            comp.tests = comp.tests + 1
                           ' #g "font courrier_new 10"
                           ' #g "place 50 ";WindowHeight-35;";|";comp.tests;"         "
                           ' #g "font courrier_new ";sc/2
                            call resolve
                            scan
                            if grille.finie() then exit sub
                            'if grille.finie() then call affgrille :#g "when characterInput player"
                            cell(xx,yy) = nbre.tamp
                        end if
                    next
                    exit sub
                end if
            next
        next
    end sub

    Function grille.finie()  'grid finished ?
        grille.finie = 1
        for yy = 1 to 9
            for xx = 1 to 9
                if cell(xx,yy) = 0 then
                    grille.finie = 0 :exit function
                end if
            next
        next
    end function

    Function ok(nbre,x,y)  'is nbre is possible in cell(x,y) ?
        string$ = "" :ok = 1
        for c = 1 to 9
            string$ = string$+" "+str$(c)+str$(y)+" "
        next
        for c = 1 to 9
            string$ = string$+" "+str$(x)+str$(c)+" "
        next
        dx = 1*(x<4)+4*(x>3 and x<7)+7*(x>6)  'corner up/left of one of the nine big square
        dy = 1*(y<4)+4*(y>3 and y<7)+7*(y>6)
        for iy = 0 to 2
            for ix = 0 to 2
                string$ = string$+" "+str$(dx+ix)+str$(dy+iy)+" "
            next
        next
        DO
            for cp = 1 to 27
                cpx = val(left$(word$(string$,cp),1))
                cpy = val(right$(word$(string$,cp),1))
                if cell(cpx,cpy) = nbre then ok = 0 :exit function
            next
        LOOP UNTIL cp = 28
    end function

    '**************************************************************************************************

    sub affgrille
        for y = 1 to 9
            for x = 1 to 9
                if cell(x,y) > 0 then
                    #g "backcolor ";bckcolor$
                    #g "place ";offset+(x-1)*sc+sc/5+sc/8;" ";offset+(y-1)*sc+sc/2+sc/4;";|";cell(x,y)
                else
                    #g "color ";bckcolor$
                    #g "place ";offset+(x-1)*sc+5;" ";offset+(y-1)*sc+5;";boxfilled ";offset+(x-1)*sc+sc-3;" ";offset+(y-1)*sc+sc-3 'erase
                    #g "color black"
                end if
            next
        next
        #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
        #g "background bckgrd"
        #g "flush; discard"
    end sub

    sub drawcube
        #g "fill ";bckcolor$
        #g "backcolor black; color black"
        #g "size 1"
        for y = 1 to 9
            for x = 1 to 9
                #g "place ";offset+(x-1)*sc;" ";offset+(y-1)*sc
                #g "box ";offset+(x-1)*sc+sc;" ";offset+(y-1)*sc+sc
            next
        next
        #g "size 4" :scBig = 3 * sc
        for yy = 1 to 3
            for xx = 1 to 3
                #g "place ";offset+(xx-1)*scBig;" ";offset+(yy-1)*scBig
                #g "box ";offset+(xx-1)*scBig+scBig;" ";offset+(yy-1)*scBig+scBig
            next
        next
        #g "backcolor ";bckcolor$;"; color black"
        #g "font courrier_new 10"
        #g "font courrier_new ";sc/2
    end sub

    sub makeSprite
        #g "size 5"
        #g "place 2 2"
        #g "box ";sc+2;" ";sc+2
        #g "backcolor black"
        #g "place 2 ";sc+2
        #g "boxfilled ";sc+2;" ";2*sc+2
        #g "color red"
        #g "place 2 ";sc+4
        #g "box ";sc+2;" ";2*sc+2
        #g "getbmp square 0 0 ";sc+4;" ";2*(sc+4)-4
        bmpsave "square" , "square.bmp"
    end sub 

User IP Logged

TyCamden

Please give credit if you use code I post, no need to ask for permission.


Just BASIC 1.01, Windows 7 Home Premium version (2009), AMD Athelon II 320 Dual-Core Processor 2.10 GHz - 4.00 GB RAM (3.75 usable) - 64-bit OS
cassiope01
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 669
xx Re: Solve SUDOKU with recursivity.
« Reply #7 on: Nov 19th, 2011, 11:40pm »

Hi guys, I am very pleased that you like it... and I am proud of that :D :D

NJames, i'm still waiting for you with the NEUTRON ;) :D

Ty : you and your phobia about SUB ;D ;D ;D
- very good improvements ;)

you could try other value for the variable sc ! care of your buttons...

on Nov 19th, 2011, 5:45pm, TyCamden wrote:
I modified your program a little, since I prefer mouse only (no keystrokes).
me too !! even more since I have just offer me a little tablet PC...! (FePad32-3G i have no WiFi at home... I'm afraid to burn my brain with that ;D ;D )
So I propose you other improvements to this effect:

before the "open..." line: Code:
    buttonsize = int(9*sc/10)
    button #g.butt0, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+0*buttonsize, buttonsize, buttonsize
    button #g.butt1, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+1*buttonsize, buttonsize, buttonsize
    button #g.butt2, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+2*buttonsize, buttonsize, buttonsize
    button #g.butt3, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+3*buttonsize, buttonsize, buttonsize
    button #g.butt4, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+4*buttonsize, buttonsize, buttonsize
    button #g.butt5, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+5*buttonsize, buttonsize, buttonsize
    button #g.butt6, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+6*buttonsize, buttonsize, buttonsize
    button #g.butt7, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+7*buttonsize, buttonsize, buttonsize
    button #g.butt8, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+8*buttonsize, buttonsize, buttonsize
    button #g.butt9, "", NumChoice, UL, WindowWidth-buttonsize-15, offset+9*buttonsize, buttonsize, buttonsize 


Unfortunately that code don't work for declaration: Code:
    'for bt = 0 to 9
    '    Bw$ = "#g.butt"+str$(bt)
    '    button #Bw$, str$(bt), NumChoice, UL, WindowWidth-buttonsize-15, offset+bt*buttonsize, buttonsize, buttonsize
    'next 


just after #g "down" : Code:
    for bt = 0 to 9
        Bw$ = "#g.butt";bt
        #Bw$ "!font courrier_new ";sc/3
        #Bw$ bt
    next 


and where you want : Code:
    sub NumChoice handle$
        if selection then
            #g "spritexy square -100 0"
            #g "drawsprites"
            cell(cx,cy) = val(right$(handle$,1))
            #g "backcolor ";bckcolor$
            if cell(cx,cy) > 0 then
                #g "place ";offset+(cx-1)*sc+sc/5+sc/8;" ";offset+(cy-1)*sc+sc/2+sc/4;";|";cell(cx,cy)
            else
                #g "color ";bckcolor$
                #g "place ";offset+(cx-1)*sc+5;" ";offset+(cy-1)*sc+5;";boxfilled ";offset+(cx-1)*sc+sc-3;" ";offset+(cy-1)*sc+sc-3 'erase
                #g "color black"
            end if
            #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
            #g "background bckgrd"
            #g "spritexy square ";offset+(cx-1)*sc-2;" ";offset+(cy-1)*sc-2
            #g "drawsprites"
        end if
    end sub 


you don't like yellow ;D ;D

on Nov 19th, 2011, 5:45pm, TyCamden wrote:
' changed the 'solve' routine from a sub, to having a [branchLabel]
I'm afraid this is not really possible ! ;D ;D ask to NJames why ;) ;)
« Last Edit: Nov 20th, 2011, 12:28am by cassiope01 » User IP Logged

"It is better to mobilize its intelligence for stupid things, rather than mobilizing its stupidity for intelligent things."
cassiope01
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 669
xx Re: Solve SUDOKU with recursivity.
« Reply #8 on: Nov 20th, 2011, 02:06am »

Better than a human, but much worse than "DeepBlue" cheesy grin

On my Intel Core Duo 2,6GHz 2Mo RAM, my poor JB took 2 min 2 sec 203 ms to solve a Diabolic grid like this :

xxx67xxxx
xxx4x9x28
x2xxxx3xx
xxxxxx5x6
xx57x49xx
9x1xxxxxx
xx2xxxx8x
85x9x6xx1
xxxx45xxx

It's still not great for a computer...!
embarassed embarassed


Ty, you have work : following what the user do with the mouse, there are many bug, due to the conversions to [branchLabel] rolleyes embarassed
« Last Edit: Nov 20th, 2011, 08:39am by cassiope01 » User IP Logged

"It is better to mobilize its intelligence for stupid things, rather than mobilizing its stupidity for intelligent things."
TyCamden
Global Moderator
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1431
xx Re: Solve SUDOKU with recursivity.
« Reply #9 on: Nov 20th, 2011, 09:34am »

on Nov 19th, 2011, 11:40pm, cassiope01 wrote:
I'm afraid this is not really possible ! ;D ;D ask to NJames why ;) ;)


Changing the code for the solve routine from a sub to using a branch label is not only possible, it is done. I posted the code in previous postings that does this already.

on Nov 20th, 2011, 02:06am, cassiope01 wrote:
Ty, you have work : following what the user do with the mouse, there are many bug, due to the conversions to [branchLabel] ::) :-[


I am sorry if you find bugs. I do not. Perhaps the following code changes will help ? ...

Insert three lines of code that disable the buttons at the beginning of the [solvePressed] routine, as follows...

Code:
[solvePressed]
    print #g.solveButton, "!disable"
    print #g.newButton, "!disable"
    print #g.quitButton, "!disable"
        #g "spritexy square -100 0"
        #g "drawsprites" 


Then re-enable those buttons at the end of that same routine, as follows...

Code:
            #g "font courrier_new ";sc/2
        #g "flush; discard"
        selection = 0
    print #g.solveButton, "!enable"
    print #g.newButton, "!enable"
    print #g.quitButton, "!enable"
    goto [mainAction] 


And do the same thing for the [newPressed] routine, so that it looks like as follows...

Code:
[newPressed]
    print #g.solveButton, "!disable"
    print #g.newButton, "!disable"
    print #g.quitButton, "!disable"
        #g "spritexy square -100 0"
        #g "drawsprites"
            redim cell(9,9)
            call drawcube
            #g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
            #g "background bckgrd"
        #g "flush; discard"
        selection = 0
    print #g.solveButton, "!enable"
    print #g.newButton, "!enable"
    print #g.quitButton, "!enable"
    goto [mainAction] 

User IP Logged

TyCamden

Please give credit if you use code I post, no need to ask for permission.


Just BASIC 1.01, Windows 7 Home Premium version (2009), AMD Athelon II 320 Dual-Core Processor 2.10 GHz - 4.00 GB RAM (3.75 usable) - 64-bit OS
TyCamden
Global Moderator
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1431
xx Re: Solve SUDOKU with recursivity.
« Reply #10 on: Nov 20th, 2011, 09:47am »

on Nov 20th, 2011, 02:06am, cassiope01 wrote:
On my Intel Core Duo 2,6GHz 2Mo RAM, my poor JB took 2 min 2 sec 203 ms to solve a Diabolic grid like this :

xxx67xxxx
xxx4x9x28
x2xxxx3xx
xxxxxx5x6
xx57x49xx
9x1xxxxxx
xx2xxxx8x
85x9x6xx1
xxxx45xxx


Took me 3 min 30 sec, 180619 ms. (See my signature below for my laptop stats.
User IP Logged

TyCamden

Please give credit if you use code I post, no need to ask for permission.


Just BASIC 1.01, Windows 7 Home Premium version (2009), AMD Athelon II 320 Dual-Core Processor 2.10 GHz - 4.00 GB RAM (3.75 usable) - 64-bit OS
TyCamden
Global Moderator
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1431
xx Re: Solve SUDOKU with recursivity.
« Reply #11 on: Nov 20th, 2011, 10:01am »

cassiope01,

Can you revise the program so that if you hit " S " it solves the whole puzzle *BUT* if you hit " H " it only solves one more unknown square.

So if you wanted to, you could:

1. hit H to get a square solved,

2. look at the newly solved square, then

3. hit H again, to get another square solved,

etc, etc.

If so, thanks !
User IP Logged

TyCamden

Please give credit if you use code I post, no need to ask for permission.


Just BASIC 1.01, Windows 7 Home Premium version (2009), AMD Athelon II 320 Dual-Core Processor 2.10 GHz - 4.00 GB RAM (3.75 usable) - 64-bit OS
cassiope01
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 669
xx Re: Solve SUDOKU with recursivity.
« Reply #12 on: Nov 20th, 2011, 10:57am »

Hmmmm...!
It could be a little bit complicate tongue

1. hit H to get a square solved, -> a square chosen by the computer or by you ?

2. look at the newly solved square, then -> it could take a long time, depending of the complexity of the grid at this moment... but if you accept to wait !

3. hit H again, to get another square solved, -> same question than #1

It could be easy to generate a grid, not printed, and then control if you put the right number at the right place, but you could find an other valid solution for some squares...
For now, i don't know how to extract multiple-solution for each square if there are... but maybe it's possible !
Actually the computer take the first solution it find for each square.

But i will think.

I may code a backup of the current grid, you think it would be helpful ?
« Last Edit: Nov 20th, 2011, 11:00am by cassiope01 » User IP Logged

"It is better to mobilize its intelligence for stupid things, rather than mobilizing its stupidity for intelligent things."
TyCamden
Global Moderator
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 1431
xx Re: Solve SUDOKU with recursivity.
« Reply #13 on: Nov 20th, 2011, 11:17am »

on Nov 20th, 2011, 10:57am, cassiope01 wrote:
Hmmmm...!
It could be a little bit complicate tongue

1. hit H to get a square solved, -> a square chosen by the computer or by you ?

2. look at the newly solved square, then -> it could take a long time, depending of the complexity of the grid at this moment... but if you accept to wait !

3. hit H again, to get another square solved, -> same question than #1

It could be easy to generate a grid, not printed, and then control if you put the right number at the right place, but you could find an other valid solution for some squares...
For now, i don't know how to extract multiple-solution for each square if there are... but maybe it's possible !
Actually the computer take the first solution it find for each square.

But i will think.

I may code a backup of the current grid, you think it would be helpful ?


Answer to question 1 - I would let the computer choose whichever square it solves first. Perhaps the program could track the order of the squares which got solved?

Answer to question 2 - I would accept to wait.

One way to do it would be if someone hits H, it still solves the whole grid (so you do not have to change that code), BUT it doesn't display ALL of the results, it would only display one square that was originally unknown.

Then if user hits Hint again, it would not have to solve the grid again, it could just display one more square of it.
User IP Logged

TyCamden

Please give credit if you use code I post, no need to ask for permission.


Just BASIC 1.01, Windows 7 Home Premium version (2009), AMD Athelon II 320 Dual-Core Processor 2.10 GHz - 4.00 GB RAM (3.75 usable) - 64-bit OS
cassiope01
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 669
xx Re: Solve SUDOKU with recursivity.
« Reply #14 on: Nov 21st, 2011, 08:23am »

A good test about JB CPU speed with SUB, Function, [BranchLabel], direct code... :

With my poor EEEPC 1000HE 2Go RAM and this Diabolic Grid:

xxx67xxxx
xxx4x9x28
x2xxxx3xx
xxxxxx5x6
xx57x49xx
9x1xxxxxx
xx2xxxx8x
85x9x6xx1
xxxx45xxx

I wrote 3 versions of the SUB resolve : (recursive)
- calling FUNCTION grille.finie() and FUNCTION ok(nbre,x,y) : 4 min 45 sec
- branchLabel -> Gosub [ok]....return and Gosub [grillefinie]...return : 4 min 25 sec
- direct code in the SUB resolve : 4 min 2 sec (code below)

Code:
    sub resolve
        for yy = 1 to 9
            for xx = 1 to 9
                if cell(xx,yy) = 0 then
                    for nb = 1 to 9
                        '-----------------------possible ?-------------------
                        string$ = "" :ok = 1
                        for c = 1 to 9
                            string$ = string$+" "+str$(c)+str$(yy)+" "
                        next
                        for c = 1 to 9
                            string$ = string$+" "+str$(xx)+str$(c)+" "
                        next
                        dx = 1*(xx<4)+4*(xx>3 and xx<7)+7*(xx>6)  'corner up/left of one of the nine big square
                        dy = 1*(yy<4)+4*(yy>3 and yy<7)+7*(yy>6)
                        for iy = 0 to 2
                            for ix = 0 to 2
                                string$ = string$+" "+str$(dx+ix)+str$(dy+iy)+" "
                            next
                        next
                        DO
                            for cp = 1 to 27
                                cpx = val(left$(word$(string$,cp),1))
                                cpy = val(right$(word$(string$,cp),1))
                                if cell(cpx,cpy) = nb then ok = 0 :exit for
                            next
                        LOOP UNTIL cp = 28 or ok = 0
                        '----------------------------------------------------
                        if ok then
                            nbre.tamp = cell(xx,yy)
                            cell(xx,yy) = nb
                            call resolve
                            scan
                            '--------------grid finished ?----------
                            grille.finie = 1
                            for gy = 1 to 9
                                for gx = 1 to 9
                                    if cell(gx,gy) = 0 then
                                        grille.finie = 0 :exit for
                                    end if
                                next
                                if grille.finie = 0 then exit for
                            next
                            '---------------------------------------
                            if grille.finie then exit sub
                            cell(xx,yy) = nbre.tamp
                        end if
                    next
                    exit sub
                end if
            next
        next
    end sub 


@+


PS : Ty, I don't forget you...!
« Last Edit: Nov 21st, 2011, 9:59pm by cassiope01 » User IP Logged

"It is better to mobilize its intelligence for stupid things, rather than mobilizing its stupidity for intelligent things."
Pages: 1 2 3  Notify Send Topic Print
« Previous Topic | Next Topic »

Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls