oups 
Sudoku
-
Le Soldat Inconnu
- Messages : 4312
- Inscription : mer. 28/janv./2004 20:58
- Localisation : Clermont ferrand OU Olsztyn
- Contact :
-
Le Soldat Inconnu
- Messages : 4312
- Inscription : mer. 28/janv./2004 20:58
- Localisation : Clermont ferrand OU Olsztyn
- Contact :
Bon, j'ai vu un bug pour la création de nouvelle grille
Le code correct
J'ai éditer le code, j'avais mal corrigé
Le code correct
Code : Tout sélectionner
Voir plus bas, code avec une erreur
Dernière modification par Le Soldat Inconnu le dim. 28/sept./2008 14:16, modifié 1 fois.
Je ne suis pas à moitié Polonais mais ma moitié est polonaise ... Vous avez suivi ?
[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]
[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]
-
Frenchy Pilou
- Messages : 2194
- Inscription : jeu. 27/janv./2005 19:07
-
Frenchy Pilou
- Messages : 2194
- Inscription : jeu. 27/janv./2005 19:07
et bien désolé mais ton programme n'a pas trouvé!
le sudo killer d'Athow à trouvé en 5 secondes ce qui est étonnant d'habitude il trouve en 15 millisecondes
La grille dans ton format
Un autre petit point ayant rentré mes chiffres et ayant demandé la résolution, pas moyen de revenir à la position de départ!
C'est sûr j'aurais dû enregistrer avant de demander la solution
le sudo killer d'Athow à trouvé en 5 secondes ce qui est étonnant d'habitude il trouve en 15 millisecondes
La grille dans ton format
Un autre petit point ayant rentré mes chiffres et ayant demandé la résolution, pas moyen de revenir à la position de départ!
C'est sûr j'aurais dû enregistrer avant de demander la solution
Dernière modification par Frenchy Pilou le sam. 27/sept./2008 10:55, modifié 1 fois.
-
Le Soldat Inconnu
- Messages : 4312
- Inscription : mer. 28/janv./2004 20:58
- Localisation : Clermont ferrand OU Olsztyn
- Contact :
-
Le Soldat Inconnu
- Messages : 4312
- Inscription : mer. 28/janv./2004 20:58
- Localisation : Clermont ferrand OU Olsztyn
- Contact :
J'ai trouvé le problème, la honte
J'avais déclaré une valeur qui devait être en flottant en integer
Donc le niveau 4 de la résolution ne marchait pas
voila le code corrrigé
J'avais déclaré une valeur qui devait être en flottant en integer
Donc le niveau 4 de la résolution ne marchait pas
voila le code corrrigé
Code : Tout sélectionner
; Auteur : Le Soldat Inconnu
; Version de PB : 4
;
; Explication du programme :
; Pour jouer au Sudoku
Structure Structure_Case
Valeur.s
ValeurMemoire.s[3]
Gadget.l
Image.l
Original.l
Souris.l
EndStructure
Enumeration
#Rechercher
#Verifier
#Sauver
#Charger
#ViderTout
#ViderReponses
#Nouvelle_Facile
#Nouvelle_Moyenne
#Nouvelle_Difficile
#Nouvelle_TresDifficile
#Info
#Barre
EndEnumeration
#Case_Nb = 9
#Case_Separation = 3
#Case_Espace = 2
#Case_ValeurDefaut = "123456789"
#Bouton_H = 25
Global Police_Gras, Police_Normal, Case_SourisActive.l, Case_T.l, SousCase_Nb.l, SousCase_T.l
Global Dim Sudoku.Structure_Case(#Case_Nb - 1, #Case_Nb - 1)
Procedure.l LoadWindowFont(Bold = -1, Italic = -1, UnderLine = -1)
Protected ncm.NONCLIENTMETRICS
ncm\cbSize = SizeOf(NONCLIENTMETRICS)
SystemParametersInfo_(#SPI_GETNONCLIENTMETRICS, SizeOf(NONCLIENTMETRICS), @ncm, 0)
If Bold = 0
ncm\lfMessageFont\lfWeight = 0
ElseIf Bold = 1
ncm\lfMessageFont\lfWeight = 700
EndIf
If Italic = 0
ncm\lfMessageFont\lfItalic = 0
ElseIf Italic = 1
ncm\lfMessageFont\lfItalic = 1
EndIf
If UnderLine = 0
ncm\lfMessageFont\lfUnderline = 0
ElseIf UnderLine = 1
ncm\lfMessageFont\lfUnderline = 1
EndIf
ProcedureReturn CreateFontIndirect_( @ncm\lfMessageFont)
EndProcedure
Procedure Information()
Texte.s = "Auteur : LSI Développements"
Texte + Chr(10) + "Site : www.lsi-dev.com"
Texte + Chr(10) + "Logiciel de programmation : PureBasic (www.purebasic.fr)"
Texte + Chr(10)
Texte + Chr(10) + "Ce logiciel est gratuit. Il est formellement interdit de le vendre sans mon autorisation écrite."
Texte + Chr(10) + "L'utilisation de ce logiciel est à vos risques et périls. Je ne pourrais pas être tenue pour responsable de tous problèmes causés par ce logiciel."
MessageRequester("Sudoku", Texte)
EndProcedure
Procedure.l ValeurValide(x, y, NouvelleGrille = 0)
If Len(Sudoku(x, y)\Valeur) <> 1 Or Sudoku(x, y)\Original
ProcedureReturn 1
EndIf
; On vérifie la ligne verticale
Compteur = 0
For yy = 0 To #Case_Nb - 1
If yy <> y And Sudoku(x, yy)\Valeur <> #Case_ValeurDefaut
If NouvelleGrille
Compteur + 1
If Compteur > Len(#Case_ValeurDefaut) / 2 ; Pour une nouvelle grille, une valeur n'est pas valide si on remplie plus de la moitié de la ligne
ProcedureReturn 0
EndIf
EndIf
If FindString(Sudoku(x, yy)\Valeur, Sudoku(x, y)\Valeur, 1)
ProcedureReturn 0
EndIf
EndIf
Next
; On vérifie la ligne horizontale
Compteur = 0
For xx = 0 To #Case_Nb - 1
If xx <> x And Sudoku(xx, y)\Valeur <> #Case_ValeurDefaut
If NouvelleGrille
Compteur + 1
If Compteur > Len(#Case_ValeurDefaut) / 2 ; Pour une nouvelle grille, une valeur n'est pas valide si on remplie plus de la moitié de la ligne
ProcedureReturn 0
EndIf
EndIf
If FindString(Sudoku(xx, y)\Valeur, Sudoku(x, y)\Valeur, 1)
ProcedureReturn 0
EndIf
EndIf
Next
; On vérifie le carré
Compteur = 0
For n = 0 To #Case_Nb - 1 Step #Case_Separation
For nn = 0 To #Case_Nb - 1 Step #Case_Separation
If x >= n And x < n + #Case_Separation And y >= nn And y < nn + #Case_Separation ; On recherche le bon carré
For xx = n To n + #Case_Separation - 1
For yy = nn To nn + #Case_Separation - 1
If xx <> x And yy <> y And Sudoku(xx, yy)\Valeur <> #Case_ValeurDefaut
If NouvelleGrille
Compteur + 1
If Compteur > Len(#Case_ValeurDefaut) / 2 ; Pour une nouvelle grille, une valeur n'est pas valide si on remplie plus de la moitié du carré
ProcedureReturn 0
EndIf
EndIf
If FindString(Sudoku(xx, yy)\Valeur, Sudoku(x, y)\Valeur, 1)
ProcedureReturn 0
EndIf
EndIf
Next
Next
EndIf
Next
Next
ProcedureReturn 1
EndProcedure
Procedure DessinCase(x, y)
; Aide sur la case
If Sudoku(x, y)\Valeur = #Case_ValeurDefaut
GadgetToolTip(Sudoku(x, y)\Gadget, "Clic droit sur une valeur pour définir la grille de départ (Valeur en orange)")
Else
GadgetToolTip(Sudoku(x, y)\Gadget, "")
EndIf
StartDrawing(ImageOutput(Sudoku(x, y)\Image))
Box(0, 0, Case_T, Case_T, $FFFFFF)
DrawingMode(#PB_2DDrawing_Transparent | #PB_2DDrawing_Outlined)
ValeurValide = ValeurValide(x, y)
If Sudoku(x, y)\Souris Or (Len(Sudoku(x, y)\Valeur) > 1 And Len(Sudoku(x, y)\Valeur) < Len(#Case_ValeurDefaut)) Or ValeurValide = 0 ; Affichage complet si on survole à la souris ou si il existe plusieurs possibilité
Index = 0
For nn = 0 To SousCase_Nb - 1
For n = 0 To SousCase_Nb - 1
Index + 1
Texte.s = Mid(#Case_ValeurDefaut, Index, 1)
If Texte
Box(n * SousCase_T, nn * SousCase_T, SousCase_T + 1, SousCase_T + 1, $E0E0E0)
If FindString(Sudoku(x, y)\Valeur, Texte, 1)
If Len(Sudoku(x, y)\Valeur) = 1 And ValeurValide ; Si on connait la valeur de la case
If Sudoku(x, y)\Original
Couleur = $0080E0
Else
Couleur = $000000
EndIf
DrawingFont(Police_Gras)
Else
Couleur = $404040
DrawingFont(Police_Normal)
EndIf
ElseIf Sudoku(x, y)\Valeur = "" ; Si on a une erreur, pas de valeur sur la case. On affiche tout les chiffres en rouge
Couleur = $0000FF
DrawingFont(Police_Normal)
ElseIf Sudoku(x, y)\Souris ; Si on est survolée par la souris
Couleur = $B0B0B0
DrawingFont(Police_Normal)
Else ; Sinon on n'affiche rien
Couleur = $FFFFFF
DrawingFont(Police_Normal)
EndIf
DrawText(n * SousCase_T + (SousCase_T - TextWidth(Texte)) / 2, nn * SousCase_T + (SousCase_T - TextHeight(Texte)) / 2, Texte, Couleur)
EndIf
Next
Next
Else ; Affichage réduit quand on ne survole pas la case
If Len(Sudoku(x, y)\Valeur) <= 1
If Sudoku(x, y)\Original
Couleur = $0080E0
Else
Couleur = $000000
EndIf
DrawingFont(Police_Gras)
Texte = Sudoku(x, y)\Valeur
If Texte = "" ; Si on a une erreur, pas de valeur sur la case. On affiche 0 en rouge
Texte = "0"
Couleur = $0000FF
EndIf
DrawText((SousCase_Nb * SousCase_T - TextWidth(Texte)) / 2, (SousCase_Nb * SousCase_T - TextHeight(Texte)) / 2, Texte, Couleur)
EndIf
EndIf
Box(0, 0, SousCase_Nb * SousCase_T + 1, SousCase_Nb * SousCase_T + 1, $000000)
StopDrawing()
; On affiche l'image
SetGadgetState(Sudoku(x, y)\Gadget, ImageID(Sudoku(x, y)\Image))
EndProcedure
Procedure CaseSelection(x, y)
; Si on a fait un clic droit, on met la case en couleur
If EventType() = #PB_EventType_RightClick
Original = 1
EndIf
; Position du clic sur l'image
Clic_X = WindowMouseX(0) - GadgetX(Sudoku(x, y)\Gadget)
Clic_Y = WindowMouseY(0) - GadgetY(Sudoku(x, y)\Gadget)
; Case cliquée
SousCase_X = Clic_X / SousCase_T
SousCase_Y = Clic_Y / SousCase_T
; Valeur cliquée
Index = SousCase_Y * SousCase_Nb + SousCase_X + 1
Valeur.s = Mid(#Case_ValeurDefaut, Index, 1)
If FindString(Sudoku(x, y)\Valeur, Valeur, 1) ; Si le chiffre cliqué exite déjà
If Len(Sudoku(x, y)\Valeur) = Len(#Case_ValeurDefaut) ; Si tous les chiffres existaient déjà, on ne garde que le chiffre cliqué
Sudoku(x, y)\Valeur = Valeur
Sudoku(x, y)\Original = Original
Else ; Sinon, on retire le chiffre cliqué
Sudoku(x, y)\Valeur = ReplaceString(Sudoku(x, y)\Valeur, Valeur, "")
If Sudoku(x, y)\Valeur = "" ; Si on a retiré tous les chiffres, on les remet tous
Sudoku(x, y)\Valeur = #Case_ValeurDefaut
Sudoku(x, y)\Original = 0
EndIf
EndIf
ElseIf Sudoku(x, y)\Valeur = "" ; Si on souhaite corriger une erreur
Sudoku(x, y)\Valeur = Valeur
Sudoku(x, y)\Original = 0
Else
; tout ce bazar, c'est pour garder les numéros dans le bon ordre
For n = 1 To Len(Sudoku(x, y)\Valeur)
Texte.s = Mid(Sudoku(x, y)\Valeur, n, 1)
Emplacement = FindString(#Case_ValeurDefaut, Texte, 1)
If Emplacement > Index
Sudoku(x, y)\Valeur = Left(Sudoku(x, y)\Valeur, n - 1) + Valeur + Right(Sudoku(x, y)\Valeur, Len(Sudoku(x, y)\Valeur) - n + 1)
Break
EndIf
If n = Len(Sudoku(x, y)\Valeur)
Sudoku(x, y)\Valeur + Valeur
Break
EndIf
Next
Sudoku(x, y)\Original = 0
EndIf
DessinCase(x, y)
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
If Len(Sudoku(x, y)\Valeur) = 1
DessinCase(x, y)
EndIf
Next
Next
EndProcedure
Procedure CaseSouris()
; Analyse de la case survolée par la souris
GadgetID = WindowFromPoint_(DesktopMouseX(), DesktopMouseY()) ; ID de la fenêtre sous la souris
Case_SourisActive = 0
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
If GadgetID(Sudoku(x, y)\Gadget) = GadgetID ; On change l'affichage de la case survolée
If Sudoku(x, y)\Souris = 0
Sudoku(x, y)\Souris = 1
DessinCase(x, y)
EndIf
Case_SourisActive = 1
Else
If Sudoku(x, y)\Souris = 1
Sudoku(x, y)\Souris = 0
DessinCase(x, y)
EndIf
EndIf
Next
Next
EndProcedure
Procedure Sauver()
Grille.s = SaveFileRequester("Sudoku - Sauver", GetCurrentDirectory() + "Grille " + FormatDate("%yyyy-%mm-%dd %hh-%ii-%ss", Date()) + ".sudoku", "Grille sudoku|*.sudoku", 0)
If Grille
If LCase(GetExtensionPart(Grille)) <> "sudoku"
Grille + ".sudoku"
EndIf
If CheckFilename(GetFilePart(Grille))
If CreatePreferences(Grille)
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
WritePreferenceString(Str(x) + "x" + Str(y), Sudoku(x, y)\Valeur)
If Len(Sudoku(x, y)\Valeur) = 1
WritePreferenceLong(Str(x) + "x" + Str(y) + " Original", Sudoku(x, y)\Original)
EndIf
Next
Next
ClosePreferences()
Else
MessageRequester("Sudoku - Erreur", "Impossible de créer la sauvegarde")
EndIf
Else
MessageRequester("Sudoku - Erreur", "Nom de fichier incorrect")
EndIf
EndIf
EndProcedure
Procedure Charger()
Grille.s = OpenFileRequester("Sudoku - Sauver", GetCurrentDirectory(), "Grille sudoku|*.sudoku", 0)
If Grille
OpenPreferences(Grille)
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
Sudoku(x, y)\Valeur = ReadPreferenceString(Str(x) + "x" + Str(y), "")
If Len(Sudoku(x, y)\Valeur) = 1
Sudoku(x, y)\Original = ReadPreferenceLong(Str(x) + "x" + Str(y) + " Original", 1)
Else
Sudoku(x, y)\Original = 0
EndIf
DessinCase(x, y)
Next
Next
ClosePreferences()
EndIf
EndProcedure
Procedure.f GrilleRemplie() ; Retourne le pourcentage de remplissage de la grille, un retour à 0 signifie que la grille est fausse
Compteur = 0
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
If Sudoku(x, y)\Valeur
Compteur + Len(Sudoku(x, y)\Valeur)
Else
ProcedureReturn 0
EndIf
Next
Next
ProcedureReturn #Case_Nb * #Case_Nb / Compteur
EndProcedure
Procedure MemoriserGrille(Index = 0)
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
Sudoku(x, y)\ValeurMemoire[Index] = Sudoku(x, y)\Valeur
Next
Next
EndProcedure
Procedure RestaurerGrille(Index = 0)
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
Sudoku(x, y)\Valeur = Sudoku(x, y)\ValeurMemoire[Index]
If Index = 0
DessinCase(x, y)
EndIf
Next
Next
EndProcedure
Procedure Analyse_Afficher()
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
DessinCase(x, y)
Next
Next
EndProcedure
Procedure Analyse(Test.l = 0, Niveau.l = 99)
Protected Nouveau.s, Evolution.l, CompteurNiveau1.l, CompteurNiveau4.l, Grille_Etat.f
; On va traiter par passe sucessive les cases jusqu'à ce qu'il ne reste plus qu'une seule possibilité dans chaque case
; Le niveau d'analyse est utiliser pour créer une nouvelle, il permet de tester la difficulté de la grille
; Utiliser pour la recherche de nouvelle grille
CompteurNiveau1 = 0
#Niveau1_Max = 6
CompteurNiveau4 = 0
; L'affichage ne se fait que si le niveau est de 99, donc si on ne recherche pas une nouvelle grille
; La recherche de nouvelle grille est complexe, il ne faut pas d'affichage pour arriver à trouver une nouvelle grille rapidement
Repeat
Repeat
Evolution = 0
If Niveau = 1
CompteurNiveau1 + 1
EndIf
;- Les lignes verticales
For x = 0 To #Case_Nb - 1
; on retire tous les cas impossible. si on a une case valide, on retire le chiffre de cette case à toutes les autres case de la ligne
If Niveau >= 1
For y = 0 To #Case_Nb - 1
If Len(Sudoku(x, y)\Valeur) = 1 ; Si case valide
For nn = 0 To #Case_Nb - 1
If nn <> y
Nouveau = RemoveString(Sudoku(x, nn)\Valeur, Sudoku(x, y)\Valeur)
If Sudoku(x, nn)\Valeur <> Nouveau
If Niveau = 99 Or CompteurNiveau1 < #Niveau1_Max
Sudoku(x, nn)\Valeur = Nouveau
Evolution = 1
EndIf
EndIf
EndIf
Next
EndIf
Next
EndIf
; Si un chiffre n'existe plus qu'une fois sur la ligne, on le valide
If Niveau >= 2
For Index = 1 To Len(#Case_ValeurDefaut)
Compteur = 0
Texte.s = Mid(#Case_ValeurDefaut, Index, 1)
For y = 0 To #Case_Nb - 1 ; on compte le nombre de fois que le chiffre existe
If FindString(Sudoku(x, y)\Valeur, Texte, 1)
Compteur + 1
nn = y
EndIf
Next
If Compteur = 1 And Sudoku(x, nn)\Valeur <> Texte ; Si le chiffre n'existe qu'une fois, on le valide
Sudoku(x, nn)\Valeur = Texte
Evolution = 1
EndIf
Next
EndIf
Next
;- Les lignes horizontales
For y = 0 To #Case_Nb - 1
; on retire tous les cas impossible. si on a une case valide, on retire le chiffre de cette case à toutes les autres case de la ligne
If Niveau >= 1
For x = 0 To #Case_Nb - 1
If Len(Sudoku(x, y)\Valeur) = 1 ; Si case valide
For n = 0 To #Case_Nb - 1
If n <> x
Nouveau = RemoveString(Sudoku(n, y)\Valeur, Sudoku(x, y)\Valeur)
If Sudoku(n, y)\Valeur <> Nouveau
If Niveau = 99 Or CompteurNiveau1 < #Niveau1_Max
Sudoku(n, y)\Valeur = Nouveau
Evolution = 1
EndIf
EndIf
EndIf
Next
EndIf
Next
EndIf
; Si un chiffre n'existe plus qu'une fois sur la ligne, on le valide
If Niveau >= 2
For Index = 1 To Len(#Case_ValeurDefaut)
Compteur = 0
Texte.s = Mid(#Case_ValeurDefaut, Index, 1)
For x = 0 To #Case_Nb - 1 ; on compte le nombre de fois que le chiffre existe
If FindString(Sudoku(x, y)\Valeur, Texte, 1)
Compteur + 1
n = x
EndIf
Next
If Compteur = 1 And Sudoku(n, y)\Valeur <> Texte ; Si le chiffre n'existe qu'une fois, on le valide
Sudoku(n, y)\Valeur = Texte
Evolution = 1
EndIf
Next
EndIf
Next
;- Les carrés
For x = 0 To #Case_Nb - 1 Step #Case_Separation
For y = 0 To #Case_Nb - 1 Step #Case_Separation
; On retire tous les cas impossible. si on a une case valide, on retire le chiffre de cette case à toutes les autres cases du carré
If Niveau >= 1
For xx = x To x + #Case_Separation - 1
For yy = y To y + #Case_Separation - 1
If Len(Sudoku(xx, yy)\Valeur) = 1 ; Si case valide
For n = x To x + #Case_Separation - 1
For nn = y To y + #Case_Separation - 1
If n <> xx And nn <> yy
Nouveau = RemoveString(Sudoku(n, nn)\Valeur, Sudoku(xx, yy)\Valeur)
If Sudoku(n, nn)\Valeur <> Nouveau
If Niveau = 99 Or CompteurNiveau1 < #Niveau1_Max
Sudoku(n, nn)\Valeur = Nouveau
Evolution = 1
EndIf
EndIf
EndIf
Next
Next
EndIf
Next
Next
EndIf
; Si un chiffre n'existe plus qu'une fois dans le carré, on le valide
If Niveau >= 2
For Index = 1 To Len(#Case_ValeurDefaut)
Compteur = 0
Texte.s = Mid(#Case_ValeurDefaut, Index, 1)
For xx = x To x + #Case_Separation - 1 ; on compte le nombre de fois que le chiffre existe
For yy = y To y + #Case_Separation - 1
If FindString(Sudoku(xx, yy)\Valeur, Texte, 1)
Compteur + 1
n = xx
nn = yy
EndIf
Next
Next
If Compteur = 1 And Sudoku(n, nn)\Valeur <> Texte ; Si le chiffre n'existe qu'une fois, on le valide
Sudoku(n, nn)\Valeur = Texte
Evolution = 1
EndIf
Next
EndIf
; Si on a 2 cases avec les mêmes 2 chiffres, alors ces 2 chiffres ne peuvent pas exister ailleurs dans le carré
If Niveau >= 3
For xx = x To x + #Case_Separation - 1
For yy = y To y + #Case_Separation - 1
For Longueur = 2 To Len(#Case_ValeurDefaut) / 2
If Len(Sudoku(xx, yy)\Valeur) = Longueur ; Si case valide
Compteur = 0
For n = x To x + #Case_Separation - 1
For nn = y To y + #Case_Separation - 1
If Sudoku(xx, yy)\Valeur = Sudoku(n, nn)\Valeur
Compteur + 1
EndIf
Next
Next
If Compteur = Longueur
For n = x To x + #Case_Separation - 1
For nn = y To y + #Case_Separation - 1
If Sudoku(xx, yy)\Valeur <> Sudoku(n, nn)\Valeur
For Index = 1 To Longueur
Texte.s = Mid(Sudoku(xx, yy)\Valeur, Index, 1)
Nouveau = RemoveString(Sudoku(n, nn)\Valeur, Texte)
If Sudoku(n, nn)\Valeur <> Nouveau
Sudoku(n, nn)\Valeur = Nouveau
Evolution = 1
EndIf
Next
EndIf
Next
Next
EndIf
EndIf
Next
Next
Next
EndIf
; Si un chiffre n'existe que sur une ligne du carré, on supprime ce chiffre des autres cases de la meme ligne (en dehors du carré en cours)
If Niveau >= 3
For Index = 1 To Len(#Case_ValeurDefaut)
Texte.s = Mid(#Case_ValeurDefaut, Index, 1)
Horizontal = 1
Vertical = 1
Compteur = 0
For xx = x To x + #Case_Separation - 1 ; On regarde ou se trouve le chiffre dans le carré
For yy = y To y + #Case_Separation - 1
If FindString(Sudoku(xx, yy)\Valeur, Texte, 1)
Compteur + 1
If Compteur > 1
If n <> xx
Vertical = 0
EndIf
If nn <> yy
Horizontal = 0
EndIf
Else
n = xx
nn = yy
EndIf
EndIf
Next
Next
If Compteur > 1 ; Si on a trouvé le même chiffre plus d'une fois, sinon, cette analyse ne sert à rien
If Vertical ; Si on n'a le chiffre que sur une verticale
For yy = 0 To #Case_Nb - 1
If yy < y Or yy > y + #Case_Separation - 1 ; Sur les autres cases de la verticale
Nouveau = RemoveString(Sudoku(n, yy)\Valeur, Texte)
If Sudoku(n, yy)\Valeur <> Nouveau
Sudoku(n, yy)\Valeur = Nouveau
Evolution = 1
EndIf
EndIf
Next
EndIf
If Horizontal ; Si on n'a le chiffre que sur une horizontale
For xx = 0 To #Case_Nb - 1
If xx < x Or xx > x + #Case_Separation - 1 ; Sur les autres cases de l'horizontale
Nouveau = RemoveString(Sudoku(xx, nn)\Valeur, Texte)
If Sudoku(xx, nn)\Valeur <> Nouveau
Sudoku(xx, nn)\Valeur = Nouveau
Evolution = 1
EndIf
EndIf
Next
EndIf
EndIf
Next
EndIf
Next
Next
;- On affiche
If Test = 0 And Niveau = 99
Analyse_Afficher()
EndIf
While WindowEvent() : Wend ; On vide les évènements
Until Evolution = 0 ; Jusqu'à ce qu'on ne trouve plus rien à faire
; Dans le dernier retranchement des possibilités, on fait un essai sur une case (on valide une valeur au hazard) et on regarde si on ne trouve PAS de solution, cela signifie que la valeur validée n'est pas possible.
; ou alors quand on valide un chiffre, si on trouve la solution finale, c'est bon.
; Mais on ne valide pas de chiffre si après l'essai, on n'a pas de solution finale. Une solution imcomplète ne permet pas de valider un chiffre.
; on ne fait cette recherche que sur les cases à 2 chiffres pour limiter, sinon, ca veut dire que cette grille est intordable sans outil informatique
If Niveau >= 4
If Test = 0 ; Si on n'est pas déjà en train de faire des tests
If GrilleRemplie() <> 1 ; Si la grille n'est pas finie, on fait un test
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
If Len(Sudoku(x, y)\Valeur) = 2 ; On recherche une case avec 2 chiffres
For Index = 1 To Len(Sudoku(x, y)\Valeur) ; On fait l'essai avec chaque valeur de la case
MemoriserGrille(1) ; On enregistre la grille pour revenir en arrière après l'essai
Texte = Mid(Sudoku(x, y)\Valeur, Index, 1) ; On valide le premier chiffre
Sudoku(x, y)\Valeur = Texte
Analyse(1, Niveau)
Grille_Etat = GrilleRemplie()
If Grille_Etat = 1
If Niveau = 99
Analyse_Afficher()
EndIf
Break 3 ; On a finis la grille
Else
If Grille_Etat = 0 ; Le test à générer une erreur
; On est sur que la valeur validée n'est pas bonne
RestaurerGrille(1)
Sudoku(x, y)\Valeur = RemoveString(Sudoku(x, y)\Valeur, Texte)
If Niveau = 99
Analyse_Afficher()
EndIf
If Niveau = 4
CompteurNiveau4 + 1
EndIf
If Niveau = 99 Or CompteurNiveau4 <= 2 ; Dans le cas de la recherche de nouvelle grille, on n'autorise que 2 tests dans la grille, sinon, c'est trop complexe à résoudre.
Evolution = 1
EndIf
Break 3 ; On a trouvé une case
Else
; Aucun résultat du test
RestaurerGrille(1)
EndIf
EndIf
Next
EndIf
Next
Next
EndIf
EndIf
EndIf
Until Evolution = 0
EndProcedure
Procedure Vider(Tout = 1, Alerte = 1)
Compteur = 0
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
If Sudoku(x, y)\Valeur <> #Case_ValeurDefaut And (Tout = 1 Or Sudoku(x, y)\Original = 0)
Compteur + 1
EndIf
Next
Next
If Compteur
If Alerte
If Tout = 1 And MessageRequester("Sudoku - Effacer", "Effacer la grille ?", #PB_MessageRequester_YesNo) = #PB_MessageRequester_No
ProcedureReturn
ElseIf Tout <> 1 And MessageRequester("Sudoku - Effacer", "Effacer les réponses ?", #PB_MessageRequester_YesNo) = #PB_MessageRequester_No
ProcedureReturn
EndIf
EndIf
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
If (Tout Or Sudoku(x, y)\Original = 0) And Sudoku(x, y)\Valeur <> #Case_ValeurDefaut
Sudoku(x, y)\Valeur = #Case_ValeurDefaut
Sudoku(x, y)\Original = 0
If Alerte
DessinCase(x, y)
EndIf
EndIf
Next
Next
EndIf
EndProcedure
Procedure Solution()
Protected Nouveau.s, Evolution.l
; On va traiter par passe sucessive les cases jusqu'à ce qu'il ne reste plus qu'une seule possibilité dans chaque case
If MessageRequester("Sudoku", "Résoudre cette grille ?", #PB_MessageRequester_YesNo) = #PB_MessageRequester_Yes
MemoriserGrille()
Vider(0)
Analyse()
If GrilleRemplie() = 0
MessageRequester("Sudoku", "Impossible de résoudre la grille proposée")
RestaurerGrille()
EndIf
EndIf
EndProcedure
Procedure Verifier()
If GrilleRemplie() <> 1
MessageRequester("Sudoku", "La grille n'est pas remplie totalement")
Else
MemoriserGrille()
Analyse()
If GrilleRemplie() <> 1
MessageRequester("Sudoku", "Grille fausse")
RestaurerGrille()
Else
MessageRequester("Sudoku", "Grille résolue")
EndIf
EndIf
EndProcedure
Procedure Nouvelle(Niveau)
Protected Grille_OK, Grille_Etat.f, Grille_Etat_Max.f
Vider(1) ; On efface la grille
; On masque les cases du milieu pour afficher une barre de progression
For x = 1 To #Case_Nb - 2
HideGadget(Sudoku(x, Int(#Case_Nb / 2))\Gadget, 1)
Next
HideGadget(#Barre, 0)
; Départ de la recherche de la nouvelle grille
Repeat
Compteur = 0
Repeat
x = Random(#Case_Nb - 1)
y = Random(#Case_Nb - 1)
If Sudoku(x, y)\Valeur = #Case_ValeurDefaut
Sudoku(x, y)\Valeur = Mid(#Case_ValeurDefaut, Random(#Case_Nb - 1) + 1, 1)
If ValeurValide(x, y, 1) ; Si on a placé une valeur possible
Sudoku(x, y)\Original = 1
Compteur + 1
If Compteur > #Case_Nb ; on ne commence le test du niveau qu'après avoir mis 9 chiffres
For Index = 1 To Niveau
MemoriserGrille(2)
Analyse(0, Index)
Grille_Etat.f = GrilleRemplie() ; Etat de la grille
If Grille_Etat <> 0
If Grille_Etat = 1 ; Si la grille est faisable
If Index < Niveau
; Le niveau de la grille est trop facile, on recommence
Break 2
Else
; On a trouvé une grille du bon niveau
Grille_OK = 1
RestaurerGrille(2)
Break 2
EndIf
Else ; Sinon, on continue d'ajouter des chiffres
If Grille_Etat > Grille_Etat_Max ; Pour calculer la progression de la recherche de la nouvelle grille
Grille_Etat_Max = Grille_Etat
SetGadgetState(#Barre, 100 * Grille_Etat_Max * Grille_Etat_Max) ; On affiche la progression
EndIf
RestaurerGrille(2)
EndIf
Else
; Valeur fausse, elle donne lieu à une résolution fausse, on l'efface
RestaurerGrille(2)
Sudoku(x, y)\Valeur = #Case_ValeurDefaut
Sudoku(x, y)\Original = 0
Break
EndIf
Next
EndIf
Else ; Si la valeur n'est pas possible, on l'efface
Sudoku(x, y)\Valeur = #Case_ValeurDefaut
EndIf
EndIf
Until Compteur > #Case_Nb * #Case_Nb / 2 ; Si on a mis trop de chiffre, on arrête et on recommence
If Grille_OK = 0 ; On efface la grille pour recommencer
Vider(1, 0)
EndIf
Until Grille_OK
; On masque la barre de progression
For x = 1 To #Case_Nb - 2
HideGadget(Sudoku(x, Int(#Case_Nb / 2))\Gadget, 0)
Next
HideGadget(#Barre, 1)
Analyse_Afficher()
EndProcedure
;- Début du programme
Police_Normal = LoadWindowFont()
Police_Gras = LoadWindowFont(1)
; Détermination de la taille des cases en fonction de la police utilisée sous windows
#Image_Taille = 40
Image = CreateImage(#PB_Any, #Image_Taille, #Image_Taille)
StartDrawing(ImageOutput(Image))
DrawingFont(Police_Normal)
; Analyse de nombre de case
; On va dessiner une matrice SousCase_Nb*SousCase_Nb
SousCase_Nb = Round(Sqr(Len(#Case_ValeurDefaut)), #PB_Round_Up)
; Taille des sous case
DrawingMode(#PB_2DDrawing_Transparent)
DrawingFont(Police_Normal)
Box(0, 0, #Image_Taille, #Image_Taille, $FFFFFF)
For Index = 1 To Len(#Case_ValeurDefaut)
Texte.s = Mid(#Case_ValeurDefaut, Index, 1)
DrawText(0, 0, Texte, $000000)
Next
; Largeur du caractere
; On n'utilise pas TextWidth() pour coller au plus près au dessin du caractère
x = 0
For n = 0 To #Image_Taille - 1
For nn = 0 To #Image_Taille - 1
If Point(n, nn) <> $FFFFFF
x + 1
Break
EndIf
Next
Next
; Hauteur du caractere
y = 0
For nn = 0 To #Image_Taille - 1
For n = 0 To #Image_Taille - 1
If Point(n, nn) <> $FFFFFF
y + 1
Break
EndIf
Next
Next
; On garde le plus grand entre x et y
If x > y
SousCase_T = x + 3
Else
SousCase_T = y + 3
EndIf
; Taille de la case totale
Case_T = SousCase_T * SousCase_Nb
StopDrawing()
FreeImage(Image)
; Création de la fenêtre et de la GadgetList
If OpenWindow(0, 0, 0, Case_T * #Case_Nb + #Case_Nb / #Case_Separation * #Case_Espace + #Case_Espace + 1, Case_T * #Case_Nb + #Case_Nb / #Case_Separation * #Case_Espace + #Case_Espace + 1 + MenuHeight(), "Sudoku", #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget) = 0 Or CreateGadgetList(WindowID(0)) = 0
End
EndIf
StickyWindow(0, 1)
SetWindowColor(0, $000000)
If CreateMenu(0, WindowID(0))
MenuTitle("Grille")
OpenSubMenu("Nouvelle grille")
MenuItem(#Nouvelle_Facile, "Facile")
MenuItem(#Nouvelle_Moyenne, "Moyenne")
MenuItem(#Nouvelle_Difficile, "Difficile")
MenuItem(#Nouvelle_TresDifficile, "Très difficile")
CloseSubMenu()
OpenSubMenu("Effacer")
MenuItem(#ViderReponses, "Les réponses")
MenuItem(#ViderTout, "Toutes les cases")
CloseSubMenu()
MenuBar()
MenuItem(#Verifier, "Vérifier")
MenuItem(#Rechercher, "Résoudre")
MenuBar()
MenuItem(#Charger, "Ouvrir")
MenuItem(#Sauver, "Enregistrer")
MenuTitle("?")
MenuItem(#Info, "Licence et développeur")
EndIf
x_Compteur = 0
x_Decalage = #Case_Espace
For x = 0 To #Case_Nb - 1
x_Compteur + 1
If x_Compteur > #Case_Separation
x_Compteur = 1
x_Decalage + #Case_Espace
EndIf
y_Compteur = 0
y_Decalage = #Case_Espace
For y = 0 To #Case_Nb - 1
y_Compteur + 1
If y_Compteur > #Case_Separation
y_Compteur = 1
y_Decalage + #Case_Espace
EndIf
Sudoku(x, y)\Valeur = #Case_ValeurDefaut
Sudoku(x, y)\Image = CreateImage(#PB_Any, Case_T, Case_T)
Sudoku(x, y)\Gadget = ImageGadget(#PB_Any, x * Case_T + x_Decalage, y * Case_T + y_Decalage, Case_T, Case_T, ImageID(Sudoku(x, y)\Image))
DessinCase(x, y)
Next
Next
; Barre de progression
ProgressBarGadget(#Barre, #Case_Espace + Case_T, #Case_Espace + Int(#Case_Nb / 2) * Case_T + Int(Int(#Case_Nb / 2) / #Case_Separation) * #Case_Espace, WindowWidth(0) - (Case_T + #Case_Espace) * 2, Case_T, 0, 100)
HideGadget(#Barre, 1)
Repeat
Event = WaitWindowEvent(100)
Select Event
Case 0, #WM_MOUSEMOVE
; Suivant la position de la souris, l'affichage des cases est différents pour une meilleur lisibilié
; Toutes les 100 ms, on regarde. ou quand la souris bouge
CaseSouris()
Case #PB_Event_Menu
Select EventMenu()
Case #Sauver
Sauver()
Case #Charger
Charger()
Case #ViderTout
Vider(1)
Case #ViderReponses
Vider(0)
Case #Rechercher
; On recherche la solution
Solution()
Case #Verifier
Verifier()
Case #Nouvelle_Facile
Nouvelle(1)
Case #Nouvelle_Moyenne
Nouvelle(2)
Case #Nouvelle_Difficile
Nouvelle(3)
Case #Nouvelle_TresDifficile
Nouvelle(4)
Case #Info
Information()
EndSelect
Case #PB_Event_Gadget
; Quand on édite une case
For x = 0 To #Case_Nb - 1
For y = 0 To #Case_Nb - 1
If EventGadget() = Sudoku(x, y)\Gadget
CaseSelection(x, y)
EndIf
Next
Next
EndSelect
Until Event = #PB_Event_CloseWindow
; On supprime les polices chargées
If Police_Normal
DeleteObject_(Police_Normal)
EndIf
If Police_Gras
DeleteObject_(Police_Gras)
EndIf
EndJe ne suis pas à moitié Polonais mais ma moitié est polonaise ... Vous avez suivi ?
[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]
[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]
-
Frenchy Pilou
- Messages : 2194
- Inscription : jeu. 27/janv./2005 19:07
AH bravo çà marche effectivement ! 
Il va falloir que je trouve une autre grille expert pour confirmer
Par contre :je charge la grille, je fait résoudre, la grille se remplit avec les chiffres ok
Mais quand je fait maintenant effacer les réponses, tout s'efface!!!
Est-ce normal?
Pouvoir garder la position avant la solution serait pourtant pas mal
A quoi correspond "vérifier"?
PS dans d'autre forum il y a une possibilité d'enregistrer tout le code en cliquant sur une touche, ce n'est pas possible de rajouter çà?
Il va falloir que je trouve une autre grille expert pour confirmer
Par contre :je charge la grille, je fait résoudre, la grille se remplit avec les chiffres ok
Mais quand je fait maintenant effacer les réponses, tout s'efface!!!
Est-ce normal?
Pouvoir garder la position avant la solution serait pourtant pas mal
A quoi correspond "vérifier"?
PS dans d'autre forum il y a une possibilité d'enregistrer tout le code en cliquant sur une touche, ce n'est pas possible de rajouter çà?
-
Le Soldat Inconnu
- Messages : 4312
- Inscription : mer. 28/janv./2004 20:58
- Localisation : Clermont ferrand OU Olsztyn
- Contact :
rentre tes valeurs avec un clic droit, elles seront en orange (valeur de base de la grille)
Il suffit de lire l'info bulle sur les cases
Si tu les rentres avec un clic gauche, c'est des réponses
Vérifier la grille, c'est quand tu as finis une grille, tu peux vérifier qu'elle est bonne.
Il suffit de lire l'info bulle sur les cases
Si tu les rentres avec un clic gauche, c'est des réponses
Vérifier la grille, c'est quand tu as finis une grille, tu peux vérifier qu'elle est bonne.
Je ne suis pas à moitié Polonais mais ma moitié est polonaise ... Vous avez suivi ?
[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]
[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]
-
Frenchy Pilou
- Messages : 2194
- Inscription : jeu. 27/janv./2005 19:07
-
Frenchy Pilou
- Messages : 2194
- Inscription : jeu. 27/janv./2005 19:07
Bon, alors là il cale le programme
J'ai rempli la première ligne (ou une diagonale) avec les chiffre de 1 à 9
éh bé j'attends toujours
Chez Athow çà roule, même avec une grille vide
Va falloir raffiner encore un peu
Autre chose : il serait bon de pouvoir arrêter la reflexion et de pouvoir ajouter des cases et de relancer la recherche
J'ai rempli la première ligne (ou une diagonale) avec les chiffre de 1 à 9
éh bé j'attends toujours
Chez Athow çà roule, même avec une grille vide
Va falloir raffiner encore un peu
Autre chose : il serait bon de pouvoir arrêter la reflexion et de pouvoir ajouter des cases et de relancer la recherche
-
Le Soldat Inconnu
- Messages : 4312
- Inscription : mer. 28/janv./2004 20:58
- Localisation : Clermont ferrand OU Olsztyn
- Contact :
-
Frenchy Pilou
- Messages : 2194
- Inscription : jeu. 27/janv./2005 19:07
-
Le Soldat Inconnu
- Messages : 4312
- Inscription : mer. 28/janv./2004 20:58
- Localisation : Clermont ferrand OU Olsztyn
- Contact :
Il n'y a pas de notion de temps
Mon algo est logique, il pense comme n'importe quel joueur de Sudoku
Je n'essaie jamais de valeur en 'vrac'.
Je retire d'abords les valeurs impossibles dans chaque cases
Je regarde si une valeur se retrouve unique sur une ligne, colonne ou carré. Si c'est le cas, je ne garde plus que cette valeur sur la case.
ensuite, je regarde dans les carrées :
- Si une valeur n'existe que sur une ligne du carré, alors je retire cette valeur des possibilités sur le reste de la ligne
- idem colonne
- si j'ai 2 cases identiques contenant les 2 valeurs possibles, alors dans toutes les autres cases du carré, je retire ces valeurs dans les possibilités
- idem avec 3 cases identiques avec 3 valeurs possibles
- idem avec 4 ....
Après tout ça, si ca ne donne rien, je fais des essais. En gros, je prend une case, et sur cette case qui a plusieurs possibilitées, j'en choisis une.
- Si j'arrive à finir la grille, ok
- Si je trouve une impossibilité en validant cette valeur, je sais que dans cette case, je peux retirer cette valeur, elle n'est pas valable
- Si par contre, je ne finis pas la grille et je ne trouve pas d'impossibilité, je ne peux rien en conclure et j'essaie avec une autre valeur.
et tout cela, je le fais en boucle tant que je trouve des choses a modifier dans la grille
Voila comment je raisonne
Mon algo est logique, il pense comme n'importe quel joueur de Sudoku
Je n'essaie jamais de valeur en 'vrac'.
Je retire d'abords les valeurs impossibles dans chaque cases
Je regarde si une valeur se retrouve unique sur une ligne, colonne ou carré. Si c'est le cas, je ne garde plus que cette valeur sur la case.
ensuite, je regarde dans les carrées :
- Si une valeur n'existe que sur une ligne du carré, alors je retire cette valeur des possibilités sur le reste de la ligne
- idem colonne
- si j'ai 2 cases identiques contenant les 2 valeurs possibles, alors dans toutes les autres cases du carré, je retire ces valeurs dans les possibilités
- idem avec 3 cases identiques avec 3 valeurs possibles
- idem avec 4 ....
Après tout ça, si ca ne donne rien, je fais des essais. En gros, je prend une case, et sur cette case qui a plusieurs possibilitées, j'en choisis une.
- Si j'arrive à finir la grille, ok
- Si je trouve une impossibilité en validant cette valeur, je sais que dans cette case, je peux retirer cette valeur, elle n'est pas valable
- Si par contre, je ne finis pas la grille et je ne trouve pas d'impossibilité, je ne peux rien en conclure et j'essaie avec une autre valeur.
et tout cela, je le fais en boucle tant que je trouve des choses a modifier dans la grille
Voila comment je raisonne
Je ne suis pas à moitié Polonais mais ma moitié est polonaise ... Vous avez suivi ?
[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]
[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]