The code to solve puzzles can be found on Roseta Code: https://www.rosettacode.org/wiki/Sudoku#FreeBASIC
https://www.rosettacode.org/wiki/Sudoku#VBA
The FreeBasic version isn't in English so I used the VBA version to compensate.
To run this you will need a few extra files (see below main code):
s16disp.dat s16disp.bin and sudoku.dat
Main Code:
Code: Select all
Dim Shared Colour(9, 9) as uLong
Dim Shared Puzzle(9, 9) as Integer
Dim Shared Solved(9, 9) as Integer
Dim Shared DispSeg(256) as String
Function CharBin(iChar as String) as String
Dim AscLeft as Integer, AscRight as Integer
Dim BinLeft as String, BinRight as String
AscLeft=Asc(Left(iChar, 1))
BinLeft=Right(String(8, 48)+Bin(AscLeft), 8)
AscRight=Asc(Right(iChar, 1))
BinRight=Right(String(8, 48)+Bin(AscRight), 8)
CharBin=BinLeft+BinRight
End Function
Function LoadData as Integer
Dim ff1 as Integer: ff1=FreeFile
Dim Bin1 as String, Bin2 as String
Dim tMid as String, tStr as String
Open "S16DISP.BIN" for Binary as #ff1
tStr=Space(516): Get #ff1, , tStr
Close #ff1
If Left(tStr, 4)<>"SD16" or Len(tStr)<>516 then
Print "Binary File Error"
LoadData=1: Exit Function
Else
tStr=Right(tStr, 512)
Dim t as Integer
For t=1 to 256: DispSeg(t)=CharBin(Mid(tStr, 2*t+1, 2)): Next
EndIf
End Function
Sub Display(ix as Integer, iy as Integer, iChar as String, ic as uLong)
Dim t as Integer, Colours(16) as Integer
iChar=DispSeg(Asc(iChar))
For t=1 to 16
If Val(Mid$(iChar, t, 1))=0 then _
Colours(t)=RGB(8, 8, 8) else Colours(t)=ic
Next
Line(ix+2, iy+1)-(ix+12, iy+1), Colours(1)
Line(ix+3, iy+2)-(ix+11, iy+2), Colours(1)
Line(ix+15, iy+1)-(ix+25, iy+1), Colours(2)
Line(ix+16, iy+2)-(ix+24, iy+2), Colours(2)
Line(ix+25, iy+4)-(ix+25, iy+11), Colours(3)
Line(ix+26, iy+3)-(ix+26, iy+12), Colours(3)
Line(ix+25, iy+16)-(ix+25, iy+23), Colours(4)
Line(ix+26, iy+15)-(ix+26, iy+24), Colours(4)
Line(ix+3, iy+25)-(ix+11, iy+25), Colours(5)
Line(ix+2, iy+26)-(ix+12, iy+26), Colours(5)
Line(ix+16, iy+25)-(ix+24, iy+25), Colours(6)
Line(ix+15, iy+26)-(ix+25, iy+26), Colours(6)
Line(ix+1, iy+15)-(ix+1, iy+24), Colours(7)
Line(ix+2, iy+16)-(ix+2, iy+23), Colours(7)
Line(ix+1, iy+3)-(ix+1, iy+12), Colours(8)
Line(ix+2, iy+4)-(ix+2, iy+11), Colours(8)
Line(ix+3, iy+13)-(ix+12, iy+13), Colours(9)
Line(ix+3, iy+14)-(ix+12, iy+14), Colours(9)
Line(ix+15, iy+13)-(ix+24, iy+13), Colours(10)
Line(ix+15, iy+14)-(ix+24, iy+14), Colours(10)
Line(ix+4, iy+4)-(ix+11, iy+11), Colours(11)
Line(ix+5, iy+4)-(ix+11, iy+10), Colours(11)
Line(ix+4, iy+5)-(ix+10, iy+11), Colours(11)
Line(ix+13, iy+3)-(ix+13, iy+11), Colours(12)
Line(ix+14, iy+3)-(ix+14, iy+11), Colours(12)
Line(ix+16, iy+11)-(ix+23, iy+4), Colours(13)
Line(ix+16, iy+10)-(ix+22, iy+4), Colours(13)
Line(ix+17, iy+11)-(ix+23, iy+5), Colours(13)
Line(ix+4, iy+23)-(ix+11, iy+16), Colours(14)
Line(ix+4, iy+22)-(ix+10, iy+16), Colours(14)
Line(ix+5, iy+23)-(ix+11, iy+17), Colours(14)
Line(ix+13, iy+16)-(ix+13, iy+24), Colours(15)
Line(ix+14, iy+16)-(ix+14, iy+24), Colours(15)
Line(ix+16, iy+16)-(ix+23, iy+23), Colours(16)
Line(ix+17, iy+16)-(ix+23, iy+22), Colours(16)
Line(ix+17 , iy+17)-(ix+22, iy+23), Colours(16)
End Sub
Sub DigiPrint(ix as Integer, iy as Integer, iText as String, ic as uLong)
Dim t as Integer
For t=1 to Len(iText)
Display 30*(t-1)+ix, iy, Mid$(iText, t, 1), ic
Next
End Sub
Sub Center(iy as Integer, iText as String, iColour as uLong)
DigiPrint 400-30*Len(iText)\2, iy, iText, iColour
End Sub
Function Valid(x as Integer, y as Integer, n as Integer) as Integer
Dim xMin as Integer, yMin as Integer
If Puzzle(x, y)<>0 then Return (Puzzle(x, y)=n)
For c as Integer=1 to 9
If Puzzle(x, c)=n then Return 0
Next
For r as Integer=1 to 9
If Puzzle(r, y)=n then Return 0
Next
xMin=1+3*Int((x-1)/3)
yMin=1+3*Int((y-1)/3)
For r as Integer=xMin to xMin+2
For c as Integer=yMin to yMin+2
If Puzzle(r, c)=n then Return 0
Next
Next
Return 1
End Function
Sub ShowBoard(ix as Integer, iy as Integer, Board() as Integer, Tag as Integer)
Dim tx as Integer, ty as Integer
ScreenLock
If Tag=1 then
Center 2, uCase("Sudoku Solver"), RGB(255, 215, 0)
Center 32, uCase("by Norby Droid"), RGB(255, 215, 0)
Center 30*iy, "+"+String(23, 45)+"+", RGB(160, 160, 160)
Center 30*(iy+4), "+"+String(23, 45)+"+", RGB(160, 160, 160)
Center 30*(iy+8), "+"+String(23, 45)+"+", RGB(160, 160, 160)
Center 30*(iy+12), "+"+String(23, 45)+"+", RGB(160, 160, 160)
EndIf
For y as Integer=1 to 9
If y<4 then ty=iy+y
If y>3 and y<7 then ty=iy+1+y
If y>6 then ty=iy+2+y
If Tag=1 then
Center 30*ty, "| | | |", RGB(160, 160, 160)
If y=5 or y=9 then
Center 30*(y+iy-1), "|-------+-------+-------|", RGB (160, 160, 160)
EndIf
EndIf
For x as Integer=1 to 9
If x<4 then tx=2*(x-1)+ix+3
If x>3 and x<7 then tx=2*(x-1)+ix+5
If x>6 then tx=2*(x-1)+ix+7
DigiPrint 30*tx, 30*ty, Str(Board(x, y)), Colour(x, y)
Next
Next
ScreenUnLock
End Sub
Sub Solve(x as Integer, y as Integer)
Dim tVal as Integer
If x>9 then
For r as Integer=1 to 9
For c as Integer=1 to 9
Solved(r, c)=Puzzle(r, c)
Next
Next
Exit Sub
EndIf
ShowBoard 0, 3, Puzzle(), 0: ' Sleep 1
If Inkey=Chr(27) then End
For n as Integer=1 to 9
If Valid(x, y, n) then
tVal=Puzzle(x, y): Puzzle(x, y)=n
If y=9 then Solve x+1, 1 else Solve x, y+1
Puzzle(x, y)=tVal
EndIf
Next
End Sub
Sub Main(Title as String)
Line (0, 478)-(799, 599), RGB(0, 0, 0), bf
Center 480, uCase(Right(Title, Len(Title)-2)), RGB(135, 206, 235)
ShowBoard 0, 3, Puzzle(), 1
Center 540, uCase("Press a key to begin"), RGB(255, 215, 32): Sleep
Line(0, 538)-(799, 599), RGB(0, 0, 0), bf
Solve 1, 1
Line(0, 478)-(799, 599), RGB(0, 0, 0), bf
Center 480, uCase("Puzzle Solved"), RGB(255, 215, 32)
ShowBoard 0, 3, Solved(), 0
Center 540, uCase("Press a key to continue"), RGB(255, 215, 32): Sleep
End Sub
Dim tVal as Integer
Dim Title as String, tStr as String
ScreenRes 800, 600, 32
SetMouse 0, 0, 0
LoadData
Dim as Integer ff=FreeFile
Open "Sudoku.dat" for input as #ff
Input #ff, tVal
For t as Integer=1 to tVal
Line Input #ff, Title
If Left(Title, 2)<>"} " then _
Close #ff: Screen 0: Print "Data Input Error": End
For y as Integer=1 to 9
Input #ff, tStr
For x as Integer=1 to 9
Dim as Integer tVal=Val(Mid(tStr, x, 1))
If tVal=0 then _
Colour(x, y)=RGB(255, 0, 0) else Colour(x, y)=RGB(0, 255, 0)
Puzzle(x, y)=Val(Mid(tStr, x, 1))
Next
Next
Main Title
Next
Close #ff
Line(0, 478)-(799, 599), RGB(0, 0, 0), bf
Center 540, uCase("Press a key to exit"), RGB(255, 215, 32): Sleep
Screen 0
Create S16DISP.DAT and copy/paste this into it:
Code: Select all
1111111111111111
0000000100010000 Open Quotes
0010000000010000 Closed Quotes
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
0000000000000000 Space
1111111111111111 !
0010000100000000 "
1111111111111111 #
1101110111010010 $
1001010111011110 %
1111111111111111 &
1111111111111111 '
0000000000001001 (
0000000000100100 )
0000000011111111 *
0000000011010010 +
1111111111111111 ,
0000000011000000 -
1111111111111111 .
0000000000001100 /
1111111100001100 0
1000110000010010 1
1110111011000000 2
1111110011000000 3
0011000111000000 4
1101110111000000 5
1101111111000000 6
1111000100000000 7
1111111111000000 8
1111110111000000 9
1111111111111111 :
1111111111111111 ;
0000000000001001 <
1111111111111111 =
0000000000100100 >
0110000001000010 ?
1111111010000010 @
1111001111000000 A
1111110001010010 B
1100111100000000 C
1111110000010010 D
1100111111000000 E
1100001111000000 F
1101111101000000 G
0011001111000000 H
1100110000010010 I
0011111000000000 J
0000001110001001 K
0000111100000000 L
0011001100101000 M
0011001100100001 N
1111111100000000 O
1110001111000000 P
1111111100000001 Q
1110001111000001 R
1100110000100001 S
1100000000010010 T
0011111100000000 U
0000001100001100 V
0011001100000101 W
0000000000101101 X
0010000111000010 Y
1100110000001100 Z
0100010000010010 [
0000000000100001 \
1000100000010010 ]
1111111111111111 ^
0000110000000000 _
1111111111111111 `
0000111010000010 a
0001111111000000 b
0000111011000000 c
0011111011000000 d
0000111010000100 e
0100000011010010 f
1101111101000000 g
0001001111000000 h
1100110000010010 i
0011111000000000 j
0000001110001001 k
0000111100000000 l
0001001011000010 m
0001001011000000 n
0001111011000000 o
1110001111000000 p
1111111100000001 q
0000001011000000 r
1100110000100001 s
0000010011010010 t
0001111000000000 u
0000001100001100 v
0001001000000101 w
0000000000101101 x
0010000111000010 y
0000100010000100 z
0100010010010010 {
0000000000010010 |
1000100001010010 }
1111111111111111 ~
1111111111111111 Character 127
0000000000100000 Inner Spin 1
0000000000010000
0000000000001000
0000000001000000
0000000000000001
0000000000000010
0000000000000100
0000000010000000
1111111100100000 Inner Spin 2
1111111100010000
1111111100001000
1111111101000000
1111111100000001
1111111100000010
1111111100000100
1111111110000000
1000000000000000 Outer Spin
0100000000000000
0010000000000000
0001000000000000
0000010000000000
0000100000000000
0000001000000000
0000000100000000
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
1111111111111111
Code: Select all
Dim t as Integer
Dim Char as String, Segment(256) as String, tStr as String
Dim ff1 as Integer, ff2 as Integer
ff1=FreeFile
Open "s16disp.dat" for Input as #ff1
For t=1 to 256
Line Input #ff1, tStr
tStr=Left$(tStr, 16)
If tStr=String$(16, 49) then tStr=String$(16, 48)
Segment(t)=Chr$(Val("&B"+Left$(tStr, 8)))+ _
Chr$(Val("&B"+Right$(tStr, 8)))
Next
Close #ff1
ff2=FreeFile
Open "s16disp.bin" for Binary as ff2
tStr="SD16": Put #ff2, , tStr
For t=1 to 256: Put #ff2, , Segment(t): Next
Close #ff2
Format for sudoku.dat is as follows:
First is the number of puzzles available in the file
Next is } followed by a title (can be anything). I currently use the difficulty level. This title is displayed under the puzzle. Note: the } character is mandatory.
Finally is three lines that hold the actual puzzle data.
Puzzle Data: Line 1, Line 2, Line 3: Line 4, Line 5, Line 6: Line 7, Line 8, Line 9
You may place them each on a separate line, or all one line.
Create sudoku.dat and copy/paste the following into it:
Code: Select all
5
} Easy
020030084,594007010,013000050
000218000,208000106,175096000
001062078,730085000,902000561
} Medium
702530080,059020010,080040000
600080409,005062008,000074500
007006000,900000700,000750106
} Hard
600107004,005040000,027060000
030005070,090030002,000200030
000006005,000051006,200400800
} Expert
000009100,000476000,000008905
500000320,800040000,090200000
076000090,000000007,004800006
} Evil
410006000,090070501,000000020
000080030,900400208,020000070
050010809,001700000,000000003