Toplam 8 sonuçtan 1 ile 8 arasındakiler gösteriliyor.

Konu: Sudoku Bulmaca

  1. #1
    Moderator
    Üyelik tarihi
    Apr 2004
    Nereden
    İstanbul
    Versiyon
    Excel 2003 TR
    Mesajlar
    1.270

    Sudoku Bulmaca

    Merhaba.

    Son dönemde popülerliği oldukça artmış olan Sudoku bulmacayı sanırım birçoğunuz duymuşsunuzdur. 9 satır 9 sütun toplam 81 hücreden oluşan bir alan 3x3 hücrelerden oluşan 9 bölüme ayrılmıştır. 1'den 9'a kadar olan rakamlar öyle bu alanlara öyle yerleştirilmelidir ki her satırda, her sütunda ve her 3x3'lük bölmede 1-9 arası rakamların tamamı 1 kez kullanılmış olsun.

    Birkaç gündür uğraştığım kodlarla çözüme ulaşmayı nihayet başardım. Ancak -sanırım- rakamlar her defasında rastgele seçildiği için teorik olarak sonuca ulaşılamama riski de mevcut ve çözüm süresi bilgisayarın performansına ve biraz da şansınıza bağlı olarak değişkenlik gösterebiliyor. :lol:

    Çözüme ulaşıldığında tabloyu kopyalayıp Sağlama isimli sayfadaki boyalı alana yapıştırarak sonucu kontrol edebilirsiniz. Yapıştırdığınızda diğer 3 tablodaki bütün değerlerin 1 sonucunu vermesi gerekiyor.

    *************
    Dosya indirme konusundaki problem nedenile ek tarafımdan silinmiştir.

  2. #2
    Moderator
    Üyelik tarihi
    Apr 2004
    Nereden
    İstanbul
    Versiyon
    Excel 2003 TR
    Mesajlar
    1.270
    İlk satırdan başlayarak satırdaki her sütuna rakamları yerleştirdikten sonra sonraki satıra geçerek aynı işlemi yineleyecek içiçe 2 döngü kullandım.

    NUmara üretme işini rastgele yaptım, her defasında 1-9 arası rastgele bir numara üretiliyor.

    Üretilen numaranın bulmacanın temel 3 şartına uyup uymadığını denetlemek için 3 farklı fonksiyon yazdım. Her bir fonksiyon bulmacanın 1 ana koşulunu (satırlarda / sütunlarda / ilgili bölümde sayının yinelenmiyor olması koşulu) denetliyor. Seçilen rakam her üç koşulu da sağlıyorsa hücreye yazılıyor. Sağlamıyorsa yeniden rakam üretiliyor.

    İlk birkaç bölüm için tamamıyla doğru yerleşim yapılsa bile bu yerleştirmeler -oyunun mantığı gereği- sonraki bölümlerde uygun dizilimi imkansız hale getirmiş olabiliyor. Bu durumu önceden bilemiyoruz. Bu nedenle böyle bir durumla karşılaştığımızda mecburen en başa dönüp tekrar başlamamız gerekiyor.

    Rastgele rakam üretme konusunda 100 şans tanıdım. Eğer 100 kez 1-9 arası rastgele rakam üretilmiş ve üretilen rakam bir sonraki adıma geçmeye imkan vermemişse o zaman yine silbaştan başlamasını sağladım. Aslında burada bir sakatlık var gibi. Çünkü 100 kez rakam üretildiği halde sonraki adıma geçilememişse bunun 2 nedeni olabilir.
    1. 100 defada da doğru rakam üretilmemiştir.
    2. 100 denemede 1-9 arası tüm rakamlar üretilmiştir, ancak çıkmaz sokağa girilmiştir, yani başa dönülmesi gerekiyordur.
    Ben 100 denemeden sonra ikinci durumun gerçekleştiğini varsaydım. 100 sayısını artırmak ya da azaltmak hem çözüme hem de süreye doğrudan etki edecektir.

    İlgi duyan arkadaşlar görüşlerini aktarırlar ya da kodda gördükleri eksik ya da yanlışları gideren alternatif kodlar sunralarsa ben de minnettar olurum.

    Kullanılan Kodlar:
    Kod:
    Sub SuDoKu()
      Dim Satir As Byte
      Dim Sutun As Byte
      Dim Numara As Byte
      Dim Sayac As Byte
      
    
    SilBastan:
    Cells.ClearContents
    Sayac = 0
    
      Randomize
      
      For Satir = 1 To 9
        For Sutun = 1 To 9
    Basla:
      If Sayac = 100 Then GoTo SilBastan
          Numara = (Rnd * 9)
          Sayac = Sayac + 1
          
          If SatirdaVarmi(Numara, Satir) = False Then
            If SutundaVarmi(Numara, Sutun) = False Then
              If BolumdeVarmi(Numara, Satir, Sutun) = False Then
                Cells(Satir, Sutun) = Numara
              Else
                GoTo Basla
              End If
            Else
              GoTo Basla
            End If
          Else
            GoTo Basla
          End If
          Sayac = 0
        Next Sutun
        Sayac = 0
      Next Satir
    End Sub
    
    Function SatirdaVarmi(Numara, Satir) As Boolean
      Dim i As Byte
      
      For i = 1 To 9
        If Cells(Satir, i) = Numara Then
          SatirdaVarmi = True
          Exit Function
        End If
      Next i
        SatirdaVarmi = False
    End Function
    
    Function SutundaVarmi(Numara, Sutun) As Boolean
      Dim i As Byte
      
      For i = 1 To 9
        If Cells(i, Sutun) = Numara Then
          SutundaVarmi = True
          Exit Function
          SutundaVarmi = False
        End If
      Next i
        SutundaVarmi = False
    End Function
    
    Function BolumdeVarmi(Numara, Satir, Sutun) As Boolean
      Dim ilkSatir As Byte
      Dim SonSatir As Byte
      Dim ilkSutun As Byte
      Dim sonSutun As Byte
      Dim y As Integer, z As Integer
      
     Select Case Satir
      Case 1 To 3
        ilkSatir = 1
        SonSatir = 3
      Case 4 To 6
        ilkSatir = 4
        SonSatir = 6
      Case 7 To 9
        ilkSatir = 7
        SonSatir = 9
     End Select
    
     Select Case Sutun
      Case 1 To 3
        ilkSutun = 1
        sonSutun = 3
      Case 4 To 6
        ilkSutun = 4
        sonSutun = 6
      Case 7 To 9
        ilkSutun = 7
        sonSutun = 9
    
     End Select
    
     For y = ilkSatir To SonSatir
      For z = ilkSutun To sonSutun
        If Cells(y, z) = Numara Then
          BolumdeVarmi = True
          Exit Function
        End If
      Next z
     Next y
     
     BolumdeVarmi = False
    End Function

  3. #3
    Moderator
    Üyelik tarihi
    Apr 2004
    Nereden
    İstanbul
    Versiyon
    Excel 2003 TR
    Mesajlar
    1.270
    Başka bir denemede farkettim ki benim izlediğim yol pek mantıklı değil. Yerleştirme işlemini satırlar, sütunlar ya da bölümler bazında yapmaya çalışmak yerine rakam bazında yapmak daha mantıklı gibi. Yani rastgele seçilen bir rakamı bütün bölmelere yerleştirip sonra kalanlar arasından yine rastgele bir rakam seçip onu bütün bölümlere yerleştirmek ve hepsi tamamlanana kadar bunu sürdürmek. Bu sistem daha doğru ve daha hızlı sonuç verecek gibi görünüyor. Üstelik çıkmaz sokaklara yakalanma riski de yok gibi görünüyor. Bu işlemi yapacak bir kod yazıp denemeye çalışacağım bakalım.

  4. #4
    Kıdemli Üye
    Üyelik tarihi
    Apr 2004
    Nereden
    Bursa
    Versiyon
    2010
    Mesajlar
    108
    Merhaba;

    Çözüm yöntemini kareler bazında yapmak daha doğru olmaz mı?
    Yani o kareye gelmesi olası rakamlar tespit edildikten sonra olasılık sayısı 1 ise kesin değer olarak kaydedilmesi ve diğer karelerde aynı işlem yapılırken bulunan rakamların da hesaba katılması yöntemi işe yarayabilir.
    Bulmacada yer alan tüm kareler dolana kadar kod çalışmaya devam edecektir.

  5. #5
    Moderator
    Üyelik tarihi
    Apr 2004
    Nereden
    İstanbul
    Versiyon
    Excel 2003 TR
    Mesajlar
    1.270
    Benim amacım mevcut bir bulmacayı çözmek değil de, sıfırdan bir bulmaca üretmekti. O nedenle böyle bir çözüm izlemiştim.

  6. #6
    Kıdemli Üye
    Üyelik tarihi
    Apr 2004
    Nereden
    İstanbul
    Versiyon
    MS Office 2007-2003 TR
    Mesajlar
    209
    Merhabalar
    Başlık olduğu için yenisini açmak istemedim.Dünya Sudoku şampiyonası yapıldı ve aşağıda gördüğünüz soruyu Çek'li bir muhasebeci bayan(meslektaşım :lol: ) 15 dakikada çözerek birinci oldu.Eh biraz zor bir soru.Ben 1 saat kadar uğraştım ama çözdüm.Merak edenlere cevabını da gönderebilirim.İlgisini çeken arkadaşlara duyrulur.




  7. #7
    Erdinç PARLAK
    Guest
    Alıntı Salih Koca Nickli Üyeden Alıntı
    Benim amacım mevcut bir bulmacayı çözmek değil de, sıfırdan bir bulmaca üretmekti. O nedenle böyle bir çözüm izlemiştim.
    Bulmaca üretmek için aşağıdaki kod bir başlangıç olabilir. Kod çalıştıktan sonra düzenli bir bulmaca üretmiş oluruz. Rakam=0 ile istediğimiz sayıdan bulmayacı oluşturmaya başlayabiliriz.

    Bulmaca oluştuktan sonra bunları karıştırmak gerekiyor. Satır ve sutunlar birlikte hareket edecek ve 3'lü grupların satır ve sutun sınırlarını aşmayacak şekilde iyice karıştırılırsa bir sudoku bulmacası elde ederiz. Karıştırma işine ilişkin bir kod yazmaya başlamıştım ancak birazda sinir olarak yarım bıraktım. Salih Bey artık karıştırma işini siz halledersiniz umarım.


    Kod:
    Sub xsudoku()
    rakam = 0
    For s = 1 To 9
    If s Mod 3 = 1 Then rakam = rakam + 1
    For c = 1 To 9
    Cells(s, c) = IIf(rakam Mod 9 = 0, 9, rakam Mod 9)
    rakam = rakam + 1
    Next
    rakam = rakam + 3
    Next
    MsgBox "Bitti"
    End Sub

  8. #8
    Kıdemli Üye
    Üyelik tarihi
    Sep 2004
    Mesajlar
    190
    Herkese selamlar,

    Salih Bey,

    Excel ile sudoku bulmacaların çözümü ve bulmaca oluşturma ile ilgili olarak değişik program örneklerini inceledim. Google ile soduku excel şeklinde aratıldığında çok miktarda sonuç çıkıyor.
    http://www.google.com/search?num=100...l&btnG=Ara&lr=

    Özellikle http://www.harismind.com/sudoku.html adresindeki program belirli zorluk derecesine kadar başarılı. Ayrıca değişik zorluklarda bulmacada oluşturabiliyor.

    Bu örnekleri incelerken bir nokta dikkatimi çekti. Karşılaştığım bütün excel sudoku dosyaları hep makro ile çözüme ulaşıyordu. Acaba makrosuz çözüme ulaşılabilir mi diye düşünerek bir aya yakın bir süredir bu konu üzerinde çalışıyorum. Belirli bir seviyeye ulaştım sayılır.
    Örneğin
    Bilal arkadaşımızın gönderdiği bulmaca
    Alıntı bilal Nickli Üyeden Alıntı
    yaptığım makrosuz excel programı ile

    yukarıdaki resimde görüldüğü gibi belirli bir noktaya kadar geliyor (Tabi verilen bulmaca oldukça zor bir seviyede olduğu için).
    Bundan sonrasında ise özellikle bulmacada yerleştirilememiş numaralardan en az sayıda kalan numaradan başlayarak deneme yanılma yöntemi ile çözüme ulaşabiliyor. Örneğin bu bulmacada sağ alt 3x3 karede 8 sayısının yerleşebileceği iki kare bulunuyor. 8 sayısının yerini bulduğumuzda bulmaca çözülüyor.


    Yapmış olduğum program henüz geliştirme aşamasında. Eğer örnekteki gibi zor bulmacaları da çözebilecek bir yol bulabilirsem excel.gen.tr'ye göndermeyi düşünüyorum.

Konu Bilgisi

Users Browsing this Thread

Şu anda 1 üyemiz bu konuya göz atıyor. (0 kayıtlı üye ve 1 misafir.)

Bu Konu İçin Etiketler

Yetkileriniz

  • Konu Acma Yetkiniz Yok
  • Cevap Yazma Yetkiniz Yok
  • Eklenti Yükleme Yetkiniz Yok
  • Mesajınızı Değiştirme Yetkiniz Yok
  •