B2B Code Show
Here is a sudoku solver written in freeBASIC by dodicat. Link is to the forum post is here.
'Sodoku solver ~ Linux/Windows
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(100,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(100,0,0)
Case Else
big(count).colour=Rgb(0,100,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,infoedge=Rgb(0,0,200),helpedge
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
Next z
If inbox(info(),mouse,1) Then
If helpflag=0 Then infoedge=Rgb(200,200,0)
End If
drawbox(info(),1,info(1).colour,1)
drawbox(info(),1,infoedge,2,"")
If inbox(info(),mouse,1) And mouse.w<>0 Then helpflag=1
If helpflag Then
drawbox(help(),0,help(0).colour,1)
drawbox(help(),0,Rgb(200,0,00),2,"")
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),"(Just click and carry, not drag)",Rgb(0,0,0)
Draw String(.41*xres,80),"Click on a Sudoku box to deposit it",Rgb(0,0,0)
Draw String(.41*xres,100),"Carry the blank to erase a number",Rgb(0,0,0)
Draw String(.41*xres,120),"Fill all your required boxes and:",Rgb(0,0,0)
Draw String(.41*xres,140),"Click solve when ready",Rgb(0,0,0)
Circle(.4*xres+50,180),20,Rgb(0,0,0)
Draw String(.4*xres+40,175),"OK",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
End Sub