Créer un jeu pour l'été

C@thy · 27 Juillet 2011

Quelqu'un connaît le Takuzu?

C'est une grille de 10x10 (ou moins pour les enfants, mais on va dire 10x10)
sur chaque ligne doivent se trouver autant de 0 que de 1 (= 5 de chaque)
pareil pour les colonnes
il ne doit pas y avoir plus de 2 0 ou 1 qui se suivent, en ligne ou en colonne

le but du jeu c'est de créer des grilles automatiques, en partie pré-remplies comme dans l'exemple joint

et aussi le solver permettant de les résoudre...

p'têt que ça existe, mais sans doute pas sous Excel

Y a-t-il un super programmeur ou un super formuliste (pour la partie résolution de grille) intéressé???

Bises à vous et bon courage!

C@thy

KenDev · 27 Juillet 2011

Re : Créer un jeu pour l'été

Bonjour Cathy,

La grille proposée as-t-elle une solution ? Pour savoir si peux m'en servir comme exemple. Cordialement

KD

KenDev · 27 Juillet 2011

Re : Créer un jeu pour l'été

Bonsoir Cathy,

Un premier essai pour la résolution bête et méchante. Je crois, sauf erreur, que la grille fournie est une grille impossible (merci...

). Pas facile de trouver des grilles sur le net ! J'en ai trouvée une de 8*8 que j'ai mise dans le classeur joint. Les colonnes M, N et lignes 12, 13 ne servent qu'à vérifier le résultat, elles peuvent être supprimées. Pas de souci donc avec cette grille mais il faudrait multiplier les essais pour voir si d'autres tests seraient nécessaires à une résolution à tout coup. Cordialement

KD

VB:

Option Explicit

Sub Taz()
Dim i%, j%, c1%, c2%, TC%(), TL%(), k%, n%

    n = Application.InputBox(prompt:="Taille de la grille ?", Default:=8)
    
    '0->3
    For i = 1 To n
        For j = 1 To n
            If Cells(i, j) <> "" Then
                Cells(i, j).Font.Color = RGB(255, 0, 0)
                If Cells(i, j) = 0 Then Cells(i, j) = 3
            End If
        Next j
    Next i
    
    Do
        'tests simples
        c1 = 0
        c2 = 0
        Do
            For i = 1 To n
                For j = 1 To n
                    If Cells(i, j) = "" Then
                        'test gauche
                        If j > 2 Then
                            If Cells(i, j - 2) = 3 And Cells(i, j - 1) = 3 Then
                                Cells(i, j) = 1
                                c1 = c1 + 1
                                Exit For
                            End If
                            If Cells(i, j - 2) = 1 And Cells(i, j - 1) = 1 Then
                                Cells(i, j) = 3
                                c1 = c1 + 1
                                c1 = c1 + 1
                                Exit For
                            End If
                        End If
                        'test droit
                        If j < n - 1 Then
                            If Cells(i, j + 2) = 3 And Cells(i, j + 1) = 3 Then
                                Cells(i, j) = 1
                                c1 = c1 + 1
                                Exit For
                            End If
                            If Cells(i, j + 2) = 1 And Cells(i, j + 1) = 1 Then
                                Cells(i, j) = 3
                                c1 = c1 + 1
                                Exit For
                            End If
                        End If
                        'test haut
                        If i > 2 Then
                            If Cells(i - 2, j) = 3 And Cells(i - 1, j) = 3 Then
                                Cells(i, j) = 1
                                c1 = c1 + 1
                                Exit For
                            End If
                            If Cells(i - 2, j) = 1 And Cells(i - 1, j) = 1 Then
                                Cells(i, j) = 3
                                c1 = c1 + 1
                                Exit For
                            End If
                        End If
                        'test bas
                        If i < n - 1 Then
                            If Cells(i + 2, j) = 3 And Cells(i + 1, j) = 3 Then
                                Cells(i, j) = 1
                                c1 = c1 + 1
                                Exit For
                            End If
                            If Cells(i + 2, j) = 1 And Cells(i + 1, j) = 1 Then
                                Cells(i, j) = 3
                                c1 = c1 + 1
                                Exit For
                            End If
                        End If
                        'test horizontal
                        If j > 1 And j < n Then
                            If Cells(i, j - 1) = Cells(i, j + 1) And Cells(i, j - 1) <> "" Then
                                Cells(i, j) = 4 - Cells(i, j - 1)
                                c1 = c1 + 1
                                Exit For
                            End If
                        End If
                        'test vertical
                        If i > 1 And i < n Then
                            If Cells(i - 1, j) = Cells(i + 1, j) And Cells(i - 1, j) <> "" Then
                                Cells(i, j) = 4 - Cells(i - 1, j)
                                c1 = c1 + 1
                                Exit For
                            End If
                        End If
                    End If
                Next j
                'test ligne
                If WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, n)), 3) = n / 2 Then
                    For j = 1 To n
                        If Cells(i, j) = "" Then
                            Cells(i, j) = 1
                            c1 = c1 + 1
                        End If
                    Next j
                End If
                If WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, n)), 1) = n / 2 Then
                    For j = 1 To n
                        If Cells(i, j) = "" Then
                            Cells(i, j) = 3
                            c1 = c1 + 1
                        End If
                    Next j
                End If
            Next i
            'test colonnes
            For j = 1 To n
                If WorksheetFunction.CountIf(Range(Cells(1, j), Cells(n, j)), 3) = n / 2 Then
                    For i = 1 To n
                        If Cells(i, j) = "" Then
                            Cells(i, j) = 1
                            c1 = c1 + 1
                        End If
                    Next i
                End If
                If WorksheetFunction.CountIf(Range(Cells(1, j), Cells(n, j)), 1) = n / 2 Then
                    For i = 1 To n
                        If Cells(i, j) = "" Then
                            Cells(i, j) = 3
                            c1 = c1 + 1
                        End If
                    Next i
                End If
            Next j
            If c1 = c2 Then Exit Do
            c2 = c1
        Loop
        
        If WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(n, n)), 1) = (n ^ 2) / 2 And WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(n, n)), 3) = (n ^ 2) / 2 Then GoTo Line1
        
        'tests croisés
        ReDim TL(1 To n, 1 To 2)
        ReDim TC(1 To n, 1 To 2)
        c1 = 0
        c2 = 0
        For i = 1 To n
            TL(i, 1) = WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, n)), 1)
            TL(i, 2) = WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, n)), 3)
            TC(i, 1) = WorksheetFunction.CountIf(Range(Cells(1, i), Cells(n, i)), 1)
            TC(i, 2) = WorksheetFunction.CountIf(Range(Cells(1, i), Cells(n, i)), 3)
        Next i
        Do
            For i = 1 To n
                For j = 1 To n
                    If Cells(i, j) = "" Then
                        For k = 1 To 2
                            If TL(i, k) * TC(j, k) = 16 Then
                                Cells(i, j) = IIf(k = 1, 1, 3)
                                c1 = c1 + 1
                                TL(i, k) = TL(i, k) + 1
                                TC(j, k) = TC(j, k) + 1
                            End If
                        Next k
                    End If
                Next j
            Next i
            If c1 = c2 Then Exit Do
            c2 = c1
        Loop
        
        If WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(n, n)), 1) = (n ^ 2) / 2 And WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(n, n)), 3) = (n ^ 2) / 2 Then GoTo Line1
    
    Loop
    
Line1:

    'retour aux 0
    For i = 1 To n
        For j = 1 To n
            If Cells(i, j) = 3 Then
                Cells(i, j) = 0
            End If
        Next j
    Next i
    
End Sub

piga25 · 27 Juillet 2011

Re : Créer un jeu pour l'été

Bonjour Cathy, KenDev

Si j'ai bien compris, ci joint la grille de cathy renseignée mais manuellement.

Edit: Oups mal compter le nb de zero et de un, correction en cours

KenDev · 27 Juillet 2011

Re : Créer un jeu pour l'été

Merci Piga,

C'est donc bien ce que j'avais vu, c'est une grille impossible puisque la résolution ne donne pas exactement 5 zéros et 5 uns à chaque ligne et colonne. Cordialement

KD

C@thy · 28 Juillet 2011

Re : Créer un jeu pour l'été

Bonjour les amis et merci pour tous vos efforts,
oui cette grille a bien une solution
je pensais a la resoudre avec des formules, un peu comme le sudoku de Jean-Marie
et plus tard son samourai (super sudoku : 5 grilles imbriquées)
toute soluce, macro ou formes est bonne à prendre
Merci à vous et bises depuis Toulouse ou je viens d'atterrir

piga25 · 28 Juillet 2011

Re : Créer un jeu pour l'été

Bonjour

Oui en effet cette grille a bien une solution que voici

C@thy · 28 Juillet 2011

Re : Créer un jeu pour l'été

Bravo joli travail!

Biz

C@thy

KenDev · 28 Juillet 2011

Re : Créer un jeu pour l'été

Bonjour Cathy, Piga,

Je suis en désaccord avec ta résolution Piga puisqu'à partir de l'étape jaune tu fais des 'choix libres'. Toutefois tu arrives à une solution correcte. J'ai également complété à la main la grille proposée et j'arrive à une autre solution. (voir fichier joint)

La grille de départ a donc au moins deux solutions, c'est suffisant pour affirmer qu'elle est incorrecte. Ou alors le jeu perd tout son intérêt à mon sens.

Je reste donc en atttente d'autres grilles, ou de liens vers d'autres grilles, pour tester la résolution par macro (mis à part la grille de 8*8 testée favorablement je n'ai trouvé que des liens vers des logiciels à installer, ce que je souhaite éviter).

Cordialement

KD

KenDev · 28 Juillet 2011

Re : Créer un jeu pour l'été

Re,

Je ne sais comment je me suis débrouillé lors du post 3 mais la macro non modifiée arrive bien à la solution du post 9 pour la grille de départ de Cathy...

Toutefois ça ne résout pas la question des solutions multiples... Pas de spécialistes de ce jeu par ici ? Cordialement

KD

pierrejean · 28 Juillet 2011

Re : Créer un jeu pour l'été

Bonjour à tous

Avant de regarder en detail vos posts:
Ma version dont je ne garantis pas qu'elle fonctionne pour tous les problemes
Par contre je suis sur qu'elle ne trouvera pas toutes les solutions

Je suis de l'avis de Kendev concernant la solution de piga d'autant qu'en B2 B3 B4 trois 0 se suivent

En sus je constate que ta solution KenDev est strictement conforme a celle a laquelle aboutit mon brouillon de macro

KenDev · 28 Juillet 2011

Re : Créer un jeu pour l'été

Re et bonjour PierreJean,

Nos deux macros trouvent la même solution et je n'avais pas vu les trois 0 dans la solution de Piga. Du coup cette solution est sans doute unique (?). Donc mes excuses, en particulier à Cathy, pour la confusion dans ce fil. La grille de départ est bien correcte comme elle nous l'a dit dès le départ.

Reste à générer maintenant des grilles... Cordialement

KD

pierrejean · 28 Juillet 2011

Re : Créer un jeu pour l'été

Re

Version avec couleurs qui permet de suivre le travail des diverses macros

Staple1600 · 28 Juillet 2011

Re : Créer un jeu pour l'été

Bonsoir à tous

Un lien pour jouer à ce jeu

PS: Bravo à tous vos solutions xdliennes
Du bien bel ouvrage que voilà

piga25 · 28 Juillet 2011

Re : Créer un jeu pour l'été

Bonjour

En effet Pierrejean il y a bien trois 0 qui se suivent mais facile à corriger, d'ailleurs ton fichier trouve la bonne combinaison.

J'ai une autre grille et là ton fichier n'arrive pas à tout remplir.

Créer un jeu pour l'été

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums