Code: Select all
' Simple GUI for SUDOKU, written by cassiope01 ( 11/18/2011 )
' Test recursivity to solve SUDOKU...
' Portage to JB from code in language C found here http://top-sudoku.com/sudoku/fr/exemple-backtracking-c.php
nomainwin
global sc, offset, cx, cy, bckcolor$, selection, comp.tests, date$
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), temp(9,9), orderinfo(81,3)
sc = 60 'size of a cell, you can try to change...!
offset = 60 'distance from the edge
bckcolor$ = "cyan" 'background color
solvedyet = 0
WindowWidth = 9 * sc + 2 * offset + offset/2
WindowHeight = WindowWidth + 20 '+ offset + offset/4
UpperLeftX = (DisplayWidth-WindowWidth) / 3
UpperLeftY = (DisplayHeight-WindowHeight) / 2
button #g.solveButton, "Solve", Solve, UL, 60, 620, 70, 30
button #g.newButton, "New", New, UL, 290, 620, 70, 30
button #g.hint, "Hint", Hint, UL, 170, 620, 70, 30
button #g.load, "Load", Load, UL, 400, 620, 70, 30
button #g.quitButton, "Quit", quit, UL, 520, 620, 70, 30
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
open " S U D O K U ..."+space$(20)+date$ for graphics_nf_nsb as #g 'window_nf
#g "trapclose quit"
#g "down"
for bt = 0 to 9
Bw$ = "#g.butt";bt
#Bw$ "!font Comic_Sans_MS ";sc/3
#Bw$ bt
next
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 Hint handle$
if grid.finished() then exit sub
#g "spritexy square -100 0"
#g "drawsprites"
#g "font courrier_new 10"
#g "place 60 ";WindowHeight-40;";|Searching a hint...."+space$(20)
#g "flush; discard"
#g "font courrier_new ";sc/2
if solvedyet = 0 then
call resolve
solvedyet = 1
end if
orderinfo(lockspot,1) = cellx
orderinfo(lockspot,2) = celly
orderinfo(lockspot,3) = cell(cellx,celly)
lockspot = lockspot + 1
'show the cell chosen in a different color...
#g "color blue"
#g "place ";offset+(cellx-1)*sc+sc/5+sc/8;" ";offset+(celly-1)*sc+sc/2+sc/4;";|";cell(cellx,celly)
#g "place 60 ";WindowHeight-40;";|";space$(120)
#g "flush; discard"
#g "color black"
#g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
#g "background bckgrd"
end sub
' below is the HINT sub as it was ORIGINALLY
#g "spritexy square -100 0"
#g "drawsprites"
#g "font courrier_new 10"
#g "place 60 ";WindowHeight-40;";|Searching a hint...."+space$(20)
#g "flush; discard"
#g "font courrier_new ";sc/2
'save cell() into temp()
for ty = 1 to 9
for tx = 1 to 9
temp(tx,ty) = cell(tx,ty)
if cell(tx,ty) = 0 then empty.cell$ = empty.cell$+str$(tx*10+ty)+" " :empty = empty + 1
next
next
'chose a random empty cell
cellx = val(left$(word$(empty.cell$,int(rnd(0)*empty)+1),1))
celly = val(right$(word$(empty.cell$,int(rnd(0)*empty)+1),1))
call resolve
temp(cellx,celly) = cell(cellx,celly)
'show the cell chosen in a different color...
#g "color blue"
#g "place ";offset+(cellx-1)*sc+sc/5+sc/8;" ";offset+(celly-1)*sc+sc/2+sc/4;";|";cell(cellx,celly)
#g "place 60 ";WindowHeight-40;";|";space$(120)
#g "flush; discard"
#g "color black"
#g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
#g "background bckgrd"
'restore cell() with temp()
for ty = 1 to 9 :for tx = 1 to 9 :cell(tx,ty) = temp(tx,ty) :next :next
' end sub
sub Load handle$
FILEDIALOG "Load grid", "*.gri", fileName$
if fileName$<>"" then
#g "spritexy square -100 0"
#g "drawsprites"
redim cell(9,9)
call drawcube
selection = 0
open fileName$ for input as #grid
for gy = 1 to 9
LINE INPUT #grid, line$
for gx = 1 to 9
c$ = mid$(line$,gx,1)
if instr("123456789",c$) then cell(gx,gy) = val(c$)
next
next
close #grid
call affgrille
end if
end sub
sub Save
if grid.finished() then exit sub
open "Grid_"+left$(date$,11)+"_"+left$(time$(),2)+mid$(time$(),4,2)+right$(time$(),2)+".gri" for output as #save
for gy = 1 to 9
line$ = ""
for gx = 1 to 9
line$ = line$ + str$(cell(gx,gy))
next
#save, line$
next
close #save
end sub
sub New handle$
#g "spritexy square -100 0"
#g "drawsprites"
redim cell(9,9)
redim orderinfo(81,3)
call drawcube
selection = 0
solvedyet = 0
end sub
sub Solve handle$
if solvedyet = 0 then
call resolve
solvedyet = 1
end if
#g "spritexy square -100 0"
#g "drawsprites"
#g "backcolor ";bckcolor$;"; color black"
#g "font courrier_new 10"
#g "place 60 ";WindowHeight-40;";|Thinking...."+space$(30)
#g "font courrier_new ";sc/2
deb = time$("ms")
comp.tests = 0
call affgrille
scan
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-(minute*60+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 60 ";WindowHeight-40;";|";res$
#g "font courrier_new ";sc/2
#g "flush; discard"
selection = 0
end sub
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+4;" ";offset+(cy-1)*sc+4;";boxfilled ";offset+(cx-1)*sc+sc-4;" ";offset+(cy-1)*sc+sc-4 '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
call Solve "#g"
case upper$(left$(inkey$,1)) = "N" ' reinit
call New "#g"
end select
#g "flush; discard"
selection = 0
end sub
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+4;" ";offset+(cy-1)*sc+4;";boxfilled ";offset+(cx-1)*sc+sc-4;" ";offset+(cy-1)*sc+sc-4 '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
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
orderspot = 1
for xx = 1 to 9
for yy = 1 to 9
if cell(xx,yy) <> 0 then
orderinfo(orderspot,1) = xx
orderinfo(orderspot,2) = yy
orderinfo(orderspot,3) = cell(xx,yy)
orderspot = orderspot + 1
end if
next yy
next xx
lockspot = orderspot - 1
for yy = 1 to 9
for xx = 1 to 9
if cell(xx,yy) = 0 then
for nb = 1 to 9
'-----------------------possible ?-------------- direct coded to improve compute speed...
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(nb,xx,yy) then
if ok then
nbre.tamp = cell(xx,yy)
cell(xx,yy) = nb
orderinfo(orderspot,1) = xx
orderinfo(orderspot,2) = yy
orderinfo(orderspot,3) = cell(xx,yy)
orderspot = orderspot + 1
' comp.tests = comp.tests + 1
' #g "font courrier_new 10"
' #g "place 60 ";WindowHeight-40;";|";comp.tests;" "
' #g "font courrier_new ";sc/2
call resolve
scan
'--------------grid finished ?---------- direct coded to improve compute speed...
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
'---------------------------------------
'if grid.finished() then exit sub
cell(xx,yy) = nbre.tamp
end if
next
exit sub
end if
next
next
end sub
'**************************************************************************************************
Function grid.finished() 'grid finished ?
grid.finished = 1
for fy = 1 to 9
for fx = 1 to 9
if cell(fx,fy) = 0 then grid.finished = 0 :exit function
next
next
end function
Function grid.empty() 'grid totally empty ?
grid.empty = 1
for ey = 1 to 9
for ex = 1 to 9
if cell(ex,ey) > 0 then grid.empty = 0 :exit function
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+4;" ";offset+(y-1)*sc+4;";boxfilled ";offset+(x-1)*sc+sc-4;" ";offset+(y-1)*sc+sc-4 '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 ";sc/2
#g "getbmp bckgrd 0 0 ";WindowWidth;" ";WindowHeight
#g "background bckgrd"
#g "flush; discard"
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$
if grid.finished() = 0 and grid.empty() = 0 then
confirm "Save ?"; sav$
if sav$ = "yes" then call Save
end if
close #g
END
end sub
