Генератор и решатель судоку
Отличный исходник генератора или решателя головоломки судоку. Исходный код
был написан на языке PureBasic. Я адаптировал его под FreeBasic , а так же
оптимизировал некоторые участки кода, в результате чего размер кода сократился
более чем вдвое.
Платформы: Windows , Linux. Дополнительно нужна библиотека
window9 .
Автор
исходного текста: rob6523 создано в 2006 году.
Адаптирование и оптимизация
кода под FreeBasic: Станислав Будинов, 2011 год
#INCLUDE "window9.bi" Type elements As Byte valeur As String valeursPossibles End Type Dim Shared sudoku(9,9) As elements Dim Shared As HWND hwnd Sub drawIm(b As hbitmap) ImageStartDraw(b) fillrectdraw(1,1,0) StopDraw End Sub Sub Open_sudoku() hwnd=OpenWindow("Генератор судоку", 0, 0, 410, 470): CenterWindow(hwnd) Var TraitHorizontal=Create_Image(388, 1) : drawIm(TraitHorizontal) Var TraitHorizontal1=Create_Image(388, 3): drawIm(TraitHorizontal1) Var TraitVertical=Create_Image(1,388): drawIm(TraitVertical) Var TraitVertical1=Create_Image(3,388): drawIm(TraitVertical1) SetGadgetFont(,LoadFont("arial",16)) Dim As Integer f=10,g=10,h For a As Integer =0 To 80 StringGadget(a, f, g, 30, 30, "", ES_NUMBER Or ES_CENTER) f+=43 If f>387 Then f=10:g+=43 Endif Next f=4:g=2 For a As Integer=83 To 92 If h>2 Or h=0 Then ImageGadget(a, 2, g, 390, 1, TraitHorizontal1) ImageGadget(a+10, g, 2, 1, 390, TraitVertical1) h=0 Else ImageGadget(a, 4, g, 390, 1, TraitHorizontal) ImageGadget(a+10, g, 2, 1, 390, TraitVertical) Endif h+=1:g+=43 Next ButtonGadget(82, 85, 400, 110, 30, "Поиск") ButtonGadget(81, 200, 400, 110, 30, "Очистить") End Sub Sub initialiser() For i As Integer =0 To 8 For j As Integer=0 To 8 sudoku(i,j).valeur = 0 sudoku(i,j).valeursPossibles = "123456789" Next j Next i End Sub Sub verifier(GadgetID_ As Integer) If (Len(GetGadgetText(GadgetID_)) > 1) Then SetGadgetText(GadgetID_, Left(GetGadgetText(GadgetID_),1)) Endif End Sub Function estResolu() As Byte Dim As Byte result = 1 For i As Integer=0 To 8 For j As Integer=0 To 8 If sudoku(i,j).valeur=0 Then result = 0 Endif Next j Next i Return result End Function Function listeValeursEnPrise(ligne As Byte,colonne As Byte) As String Dim As String result = "" For i As Byte=0 To 8 If ((i <> colonne) And (sudoku(ligne,i).valeur <> 0)) Then result += Str(sudoku(ligne,i).valeur) Endif Next i For i As Byte=0 To 8 If ((i <> ligne) And (sudoku(i,colonne).valeur <> 0)) Then result += Str(sudoku(i,colonne).valeur) Endif Next i For i As Byte=(ligne\3)*3 To ((ligne\3)*3)+2 For j As Byte=(colonne\3)*3 To ((colonne\3)*3)+2 If ((i<>ligne) And (j<>colonne) And (sudoku(i,j).valeur <> 0)) Then result += Str(sudoku(i,j).valeur) Endif Next j Next i Return result End Function Sub simplifierSudoku() Dim As Byte ligne,colonne While((ligne<9)) If (sudoku(ligne,colonne).valeur = 0) Then Dim As String valeursImpossibles = listeValeursEnPrise(ligne,colonne) While Len(valeursImpossibles)>0 sudoku(ligne,colonne).valeursPossibles=ReplaceString(sudoku(ligne,colonne).valeursPossibles,Left(valeursImpossibles,1),"") valeursImpossibles = ReplaceString(valeursImpossibles,Left(valeursImpossibles,1),"") Wend If(Len(sudoku(ligne,colonne).valeursPossibles)=1) Then sudoku(ligne,colonne).valeur = Val(Left(sudoku(ligne,colonne).valeursPossibles,1)) ligne = 0 colonne = -1 Endif Endif colonne += 1 If colonne = 9 Then colonne = 0 ligne += 1 Endif Wend End Sub Function resoudreParBackTracking(ligne As Byte, colonne As Byte) As Byte If (ligne = 9) Then Return 1 If (sudoku(ligne, colonne).valeur = 0) Then Dim As Byte i=1, trouve While ((i < (Len(sudoku(ligne, colonne).valeursPossibles)) + 1) And (trouve = 0)) If ((Instr(listeValeursEnPrise(ligne,colonne),Mid(sudoku(ligne,colonne).valeursPossibles,i,1))) = 0) Then sudoku(ligne,colonne).valeur = Val(Mid(sudoku(ligne,colonne).valeursPossibles,i,1)) colonne += 1 If colonne = 9 Then colonne = 0 ligne += 1 Endif trouve=resoudreParBackTracking(ligne, colonne) If (trouve = 0) Then colonne = colonne - 1 If colonne = -1 Then colonne = 8 ligne = ligne -1 Endif If ligne <> -1 Then sudoku(ligne,colonne).valeur = 0 Else Return 0 Endif Endif Endif i += 1 Wend Return trouve Else colonne += 1 If colonne = 9 Then colonne = 0 ligne += 1 Endif Return resoudreParBackTracking(ligne, colonne) Endif End Function Open_sudoku() Dim As Integer event,GadgetID_ Do Event = WaitEvent() If Event = EventGadget Then GadgetID_ = EventNumber If GadgetID_ = 82 Then DisableGadget(82, 1) SetGadgetText(82,"Поиск...") initialiser() Dim As Byte ligne,colonne,verif Dim As String message For i As Byte=0 To 80 If GetGadgetText(i) <> "" Then sudoku(ligne,colonne).valeur = Val(GetGadgetText(i)) Endif colonne += 1 If colonne = 9 Then colonne = 0 ligne += 1 Endif Next i For ligne=0 To 8 For colonne=0 To 8 If (sudoku(ligne,colonne).valeur <> 0) And (Instr(listeValeursEnPrise(ligne,colonne),Str(sudoku(ligne,colonne).valeur)) <> 0) Then verif = 1 Endif Next colonne Next ligne If verif = 1 Then MessBox("Ошибка в судоку !!!", "Решение этого судоку не может быть найден") Else Var Debut = Timer simplifierSudoku() If estResolu() = 0 Then resoudreParBackTracking(0,0) message = "Решение найдено за " + Str(Timer - Debut) + " миллисекунд(ы)." Else message = "Решение найдено за " + Str(Timer - Debut) + " миллисекунд(ы)." Endif ligne = 0 colonne = 0 For i As Byte=0 To 80 If sudoku(ligne, colonne).valeur <>0 Then SetGadgetText(i,Str(sudoku(ligne, colonne).valeur)) Endif colonne += 1 If colonne = 9 Then colonne = 0 ligne += 1 Endif Next i MessBox("Решение найдено!", message) Endif DisableGadget(82, 0) SetGadgetText(82,"Поиск") Elseif GadgetID_ = 81 Then For i As Byte=0 To 80 SetGadgetText(i, "") Next i Elseif ((GadgetID_ >= 0) And (GadgetID_ <= 80)) Then verifier(GadgetID_) Endif Endif Loop Until Event =EventClose
