Sudoku Generator [noch nicht ausgereift]

Übersicht BlitzBasic Allgemein

Neue Antwort erstellen

TheProgrammer

Betreff: Sudoku Generator [noch nicht ausgereift]

 BeitragSo, März 26, 2006 19:30
Antworten mit Zitat
Benutzer-Profile anzeigen
Hi.

Ich habe gerade den Ansatz eines Sudoku-Generators programmiert. Ich setzte ihn aber mit Absicht nicht in das Code-archiv, da er noch nicht ausgereift ist. Der Generator trägt lediglich per Zufall die Zahlen ein mit der Bedingung, dass die Zahl noch nicht in der Reihe existiert. Das Programm geht alle Zahlen von 1-9 nacheinander durch. Sollten sich die Reihen "zugebaut" haben und es passen keine Zahlen mehr rein, beginnt der generator von vorne. Diese Technik ist natürlich nicht gerade die beste. Deshalb kann man damit nur die Zahlen 1-5 ordentlich generieren lassen, ohne dass man Stunden warten muss. Der Parameter bei CreateSudoku gibt an, wie viele Zahlen eingetragen werden sollen.

Hier ist erstmal der Code:
Code: [AUSKLAPPEN]

Graphics 640,480,32,2
SetBuffer BackBuffer()
SeedRnd MilliSecs()

Dim sudoku$(8,8)
CreateSudoku(5)

While Not KeyHit(1)
 Cls

 Color 255,255,255
 For y = 0 To 8
  For x = 0 To 8

   Text x*20+10,y*20+10,sudoku(x,y),1,1
   Rect x*20,y*20,20,20,0

  Next
 Next

 Color 255,0,0
 For y = 0 To 8 Step 3
  For x = 0 To 8 Step 3

   Rect x*20,y*20,60,60,0

  Next
 Next

 Flip
Wend
End

Function CreateSudoku(zahl%=9)

   Repeat
    abbr = 0

    For y = 0 To 8
     For x = 0 To 8
      sudoku(x,y) = ""
     Next
    Next
   
    For I = 1 To zahl%
   
     For y = 0 To 8 Step 3
      For x = 0 To 8 Step 3
      
       count = 0
       Repeat
        a = 0
        b = 0
        c = 0
        posx = Rand(x,x+2)
        posy = Rand(y,y+2)
   
        If sudoku(posx,posy) = "" Then
         For px = 0 To 8
          If px <> posx Then
           If sudoku(px,posy) = I Then b = 1
          EndIf
         Next
         For py = 0 To 8
          If py <> posy Then
           If sudoku(posx,py) = I Then c = 1
          EndIf
         Next
         If b = 0 And c = 0 Then
          sudoku(posx,posy) = I
          a = 1
         EndIf
        EndIf
        count = count + 1
        If count = 9 Then abbr = 1
        If abbr = 1 Then Exit
       Until a = 1
   
       If abbr = 1 Then Exit
      Next
      If abbr = 1 Then Exit
     Next
     If abbr = 1 Then Exit
    Next
   
   Until abbr = 0

End Function


Das Programm ist natürlich nur ein kleiner Versuch von mir. Vielleicht habt ihr ja Ideen, wie man die Positionen der Zahlen besser berechnen lassen kann.

Mfg
TheProgrammer
aktuelles Projekt: The last day of human being
 

Florian

 BeitragSo, März 26, 2006 20:39
Antworten mit Zitat
Benutzer-Profile anzeigen
ESC Beenden
F1 lösen
F2 Löschen
F3 Erstellen
F4 Renerator
F5 Speicher in einer Txt-Datei

Code: [AUSKLAPPEN]

Global MaxFelder
Global MaxMatrix
Global Feldbreite=50
Global CursorX=1
Global CursorY=1

Global Timer=CreateTimer(25)

Dim Feld(0,0)
Dim Meoglich$(0,0)

Graphics 640,480,0,2
SetBuffer BackBuffer()

Global Fett=LoadFont("Arial",36,False,False,False)
Global Schriftnormal=LoadFont("Arial",12,False,False,False)

SeedRnd MilliSecs()


InstZahlenPuzzle 3,3

SetFeld 1,1,1,1,5

SetFeld 1,1,2,1,3
SetFeld 1,1,1,2,7
SetFeld 1,1,2,2,9
SetFeld 1,1,3,2,2
SetFeld 1,1,2,3,4

SetFeld 2,1,3,1,4
SetFeld 2,1,2,3,2
SetFeld 2,1,3,3,6

SetFeld 3,1,1,1,1
SetFeld 3,1,2,1,2
SetFeld 3,1,3,2,4
SetFeld 3,1,1,3,9
SetFeld 3,1,3,3,3

SetFeld 1,2,3,2,5
SetFeld 1,2,1,3,3
SetFeld 1,2,3,3,8

SetFeld 2,2,2,1,7
SetFeld 2,2,3,1,2
SetFeld 2,2,1,2,6
SetFeld 2,2,1,3,5


SetFeld 3,2,1,1,6
SetFeld 3,2,3,1,5
SetFeld 3,2,1,3,7

SetFeld 1,3,1,1,9
SetFeld 1,3,3,1,4
SetFeld 1,3,1,2,1
SetFeld 1,3,2,3,5
SetFeld 1,3,3,3,3

SetFeld 2,3,1,1,2
SetFeld 2,3,3,1,1
SetFeld 2,3,1,3,4

SetFeld 3,3,2,1,7
SetFeld 3,3,1,2,4
SetFeld 3,3,3,3,8

ZahlenPuzzleBearbeiten
WaitKey

Function ErstellsPuzzleTest()
 Repeat
  Zahl=Zahl+1
 Until PuzzleErstellen()=True 
End Function 

Function PuzzleErstellen()
 AlleBits=2^2 +2^3+ 2^4+ 2^5 +2^6 +2^7+ 2^8+ 2^9+ 2^10


 For X=1 To MaxFelder*MaxMatrix
  For Y=1 To MaxFelder*MaxMatrix
   Feld(X,Y)=0
  Next
 Next
 

 For X=1 To MaxFelder*MaxMatrix
  For Y=1 To MaxFelder*MaxMatrix
   ZufallsZahlBit=0

   MatrixX=Ceil#((X-1)/MaxFelder)+1
   MatrixY=Ceil#((Y-1)/MaxFelder)+1

   zahl=0
   Repeat

    WertGefunden=True

    ZufallsZahl=Rand(1,MaxFelder*MaxMatrix)
    ZufallsZahlBit=Setflag(ZufallsZahlBit,ZufallsZahl)
 
    If WertInMatrix(MatrixX,MatrixY,ZufallsZahl)=True Then
     WertGefunden=False
    EndIf
 
    For Pos=1 To MaxFelder*MaxMatrix
     If Pos<>X Then
      If Feld(Pos,Y)=ZufallsZahl Then
       WertGefunden=False
      EndIf
     EndIf
     If Pos<>Y Then
      If Feld(X,Pos)=ZufallsZahl Then
       WertGefunden=False
      EndIf
     EndIf       
    Next

    Zahl=Zahl+1

    If Zahl>100 Then Return False

   Until WertGefunden=True
   Feld(X,Y)=ZufallsZahl
  Next
 Next
 Return True
End Function

Function WertInMatrix(MatrixX,MatrixY,Zahl)
 For FeldPosX=1 To MaxFelder
  For FeldPosY=1 To MaxFelder
   If GetFeld(MatrixX,MatrixY,FeldPosX,FeldPosY)=Zahl Then
    Return True   
   EndIf
  Next
 Next
End Function

Function ZahlenPuzzleBearbeiten()
 Repeat

  Key$=""
  If KeyHit(82)=True Or KeyHit(11)=True Then Key$="0"
  If KeyHit(79)=True Or KeyHit( 2)=True Then Key$="1"
  If KeyHit(80)=True Or KeyHit( 3)=True Then Key$="2"
  If KeyHit(81)=True Or KeyHit( 4)=True Then Key$="3"
  If KeyHit(75)=True Or KeyHit( 5)=True Then Key$="4"
  If KeyHit(76)=True Or KeyHit( 6)=True Then Key$="5"
  If KeyHit(77)=True Or KeyHit( 7)=True Then Key$="6"
  If KeyHit(71)=True Or KeyHit( 8)=True Then Key$="7"
  If KeyHit(72)=True Or KeyHit( 9)=True Then Key$="8"
  If KeyHit(73)=True Or KeyHit(10)=True Then Key$="9"


  If KeyHit(208)=True Then
   If CursorY<MaxFelder*MaxMatrix Then
    CursorY=CursorY+1
   EndIf
  EndIf

  If KeyHit(200)=True Then
   If CursorY>1 Then
    CursorY=CursorY-1
   EndIf
  EndIf

  If KeyHit(205)=True Then
   If CursorX<MaxFelder*MaxMatrix Then
    CursorX=CursorX+1
   EndIf
  EndIf

  If KeyHit(203)=True Then
   If CursorX>1 Then
    CursorX=CursorX-1
   EndIf
  EndIf 


  If KeyHit(15)=True Then
  EndIf 

  If KeyHit(201)=True Then
   CursorY=1
  EndIf

  If KeyHit(209)=True Then
   CursorY=MaxFelder*MaxMatrix
  EndIf

   If KeyHit(57)=True Then
    Feld(CursorX,CursorY)=0
   EndIf

  If KeyDown(29)=True Or KeyDown(157)=True Then

   If KeyHit(207)=True Then
    CursorY=MaxFelder*MaxMatrix
   EndIf

   If KeyHit(199)=True Then
    CursorY=1
   EndIf

  Else

   If KeyHit(207)=True Then
    CursorX=MaxFelder*MaxMatrix
   EndIf

   If KeyHit(199)=True Then
    CursorX=1
   EndIf

  EndIf

  If KeyHit(211)=True Then
   Feld(CursorX,CursorY)=0
  EndIf

  If KeyHit(60)=True Then
   For X=1 To MaxFelder*MaxMatrix
    For Y=1 To MaxFelder*MaxMatrix
     Feld(X,Y)=0
    Next
   Next
  EndIf

  If KeyHit(28)=True Or KeyHit(59)=True Or KeyHit(156)=True Then
   For X=1 To 20
    ZahlenPuzzleBerechen
   Next
  EndIf

  If KeyHit(1)=True Then
   Return
  EndIf


  If KeyHit(61)=True Then
   ErstellsPuzzleTest
  EndIf

  If KeyHit(62)=True Then
   ErstellsPuzzleTest
   Zahl=MaxFelder*MaxMatrix*MaxFelder*MaxMatrix
   For Versuch=1 To Zahl/2
    Gefunden=False
    Repeat
     X=Rand(1,MaxFelder*MaxMatrix)
     Y=Rand(1,MaxFelder*MaxMatrix)
     If Feld(X,Y)<>0 Then
      Gefunden=True
      Feld(X,Y)=0
     EndIf
    Until Gefunden=True
   Next
   Gefunden=False 
  EndIf

  If KeyHit(63)=True Then
   AusgabeInDatei
  EndIf
 


  If Len(Key$)>0 Then

   WertSetzen=True
   MatrixX=Ceil#((CursorX-1)/MaxFelder)+1
   MatrixY=Ceil#((CursorY-1)/MaxFelder)+1

   For FeldPosX=1 To MaxFelder
    For FeldPosY=1 To MaxFelder
     If Not(FeldPosX=CursorX And FeldPosY=CursorY) Then
      If GetFeld(MatrixX,MatrixY,FeldPosX,FeldPosY)<>0 Then
       If GetFeld(MatrixX,MatrixY,FeldPosX,FeldPosY)=Int(Key$) Then
        WertSetzen=False 
       EndIf
      EndIf
     EndIf
    Next
   Next

   For Pos=1 To MaxFelder*MaxMatrix
    If Pos<>CursorX Then
     If Feld(Pos,CursorY)<>0 Then
      If Feld(Pos,CursorY)=Int(Key$) Then
       WertSetzen=False
      EndIf
     EndIf
    EndIf
    If Pos<>CursorY Then
     If Feld(CursorX,Pos)<>0 Then
      If Feld(CursorX,Pos)=Int(Key$) Then
       WertSetzen=False
      EndIf
     EndIf
    EndIf       
   Next

   If WertSetzen=True
    Feld(CursorX,CursorY)=Key$
    If CursorX<MaxFelder*MaxMatrix Then
     CursorX=CursorX+1
    ElseIf CursorY<MaxFelder*MaxMatrix Then
     CursorY=CursorY+1
     CursorX=1
    EndIf
   EndIf
  EndIf

  ZahlenPuzzleAnzeigenBeimBearbeiten
  WaitTimer Timer
  Flip
 Forever 
End Function

Function ZahlenPuzzleAnzeigenBeimBearbeiten()
 Cls
 Color 255,0,0
 Rect (CursorX-1)*Feldbreite,(CursorY-1)*Feldbreite,Feldbreite,Feldbreite

 Color 255,255,255
 For X=1 To MaxFelder*MaxMatrix
  For Y=1 To MaxFelder*MaxMatrix
   If Feld(X,Y)<>0 Then
    SetFont Fett
    Text (X-0.5)*Feldbreite,(Y-0.5)*Feldbreite,Feld(X,Y),True,True   
   EndIf 
  Next
 Next
 Color 255,255,255
 For X=1 To MaxMatrix
  For Y=1 To MaxMatrix
   Rect (X-1)*Feldbreite*MaxFelder,(Y-1)*Feldbreite*MaxFelder,Feldbreite*MaxFelder,Feldbreite*MaxFelder,0
  Next
 Next
End Function

Function ZahlenPuzzle()
 For X=1 To MaxFelder*MaxMatrix
  For Y=1 To MaxFelder*MaxMatrix
   If Feld(X,Y)<>0 Then
    SetFont Fett
    Text (X-0.5)*Feldbreite,(Y-0.5)*Feldbreite,Feld(X,Y),True,True
   Else
    SetFont SchriftNormal
    Text (X-0.5)*Feldbreite,(Y-0.5)*Feldbreite,Meoglich$(X,Y),True,True     
   EndIf 
  Next
 Next
 Color 255,255,255
 For X=1 To MaxMatrix
  For Y=1 To MaxMatrix
   Rect (X-1)*Feldbreite*MaxFelder,(Y-1)*Feldbreite*MaxFelder,Feldbreite*MaxFelder,Feldbreite*MaxFelder,0
  Next
 Next
End Function




Function removeflag(var,flag)
 var= var And ($ffffffff-2^flag)
 Return var
End Function

Function Setflag(var,flag)
 var= var And ($ffffffff+2^flag)
 Return var
End Function

Function ZahlenPuzzleBerechen()
 Werte=2^2 +2^3+ 2^4+ 2^5 +2^6 +2^7+ 2^8+ 2^9+ 2^10

 For X=1 To 9
  For Y=1 To 9
   If Feld(X,Y)=0 Then
    MatrixX=Ceil#((X-1)/MaxFelder)+1
    MatrixY=Ceil#((Y-1)/MaxFelder)+1
    Erlaubt=Werte


    For FeldPosX=1 To MaxFelder
     For FeldPosY=1 To MaxFelder
      If Not(FeldPosX=X And FeldPosY=Y) Then
       If GetFeld(MatrixX,MatrixY,FeldPosX,FeldPosY)<>0 Then
        Erlaubt= removeflag(Erlaubt,GetFeld(MatrixX,MatrixY,FeldPosX,FeldPosY)+1)
       EndIf   
      EndIf
     Next
    Next

    For Pos=1 To MaxFelder*MaxMatrix
     If Pos<>X Then
      If Feld(Pos,Y)<>0 Then
       Erlaubt=removeflag(Erlaubt,Feld(Pos,Y)+1)
      EndIf
     EndIf
     If Pos<>Y Then
      If Feld(X,Pos)<>0 Then
       Erlaubt=removeflag(Erlaubt,Feld(X,Pos)+1)
      EndIf
     EndIf       
    Next
     
    For Zahl=1 To 9
     If Erlaubt=2^(Zahl+1) Then
      Feld(X,Y)=Zahl
     EndIf
    Next
    Meoglich$(X,Y)=""

    For Zahl=1 To 9
     If Erlaubt And (2^(Zahl+1)) Then
      If Len(Meoglich$(X,Y))=0 Then
       Meoglich$(X,Y)= Str$(Zahl)
      Else
       Meoglich$(X,Y)= Meoglich$(X,Y)+","+Str$(Zahl)
      EndIf
     EndIf 
    Next 
   EndIf
  Next
 Next 
End Function

Function ZahlenPuzzleAnZeigen()
 For X=1 To MaxFelder*MaxMatrix
  For Y=1 To MaxFelder*MaxMatrix
   If Feld(X,Y)<>0 Then
    SetFont Fett
    Text (X-0.5)*Feldbreite,(Y-0.5)*Feldbreite,Feld(X,Y),True,True
   Else
    SetFont SchriftNormal
    Text (X-0.5)*Feldbreite,(Y-0.5)*Feldbreite,Meoglich$(X,Y),True,True     
   EndIf 
  Next
 Next
 Color 255,255,255
 For X=1 To MaxMatrix
  For Y=1 To MaxMatrix
   Rect (X-1)*Feldbreite*MaxFelder,(Y-1)*Feldbreite*MaxFelder,Feldbreite*MaxFelder,Feldbreite*MaxFelder,0
  Next
 Next
End Function

Function InstZahlenPuzzle(WMaxFelder,WMaxMatrix)
 MaxFelder=WMaxFelder
 MaxMatrix=WMaxMatrix
 Dim Feld(MaxMatrix*MaxFelder,MaxMatrix*MaxFelder)
 Dim Meoglich$(MaxMatrix*MaxFelder,MaxMatrix*MaxFelder)
End Function

Function AusgabeInDatei()
 Local Aus$[3]
 Abstand=2

 FileNr=WriteFile("Puzzle.Txt")
 For MatrixY=1 To MaxMatrix
  WriteLine FileNr,String$("+"+String$("-",MaxFelder*Abstand),MaxMatrix)+"+"
  For MatrixX=1 To MaxMatrix
   For FeldNr=1 To MaxFelder
    Aus[FeldNr]=Aus[FeldNr]+"|"
   Next
   For FeldY=1 To MaxFelder
    For FeldX=1 To MaxFelder
     Aus[FeldY]=Aus[FeldY]+String$(" ",Abstand-1)+GetFeld(MatrixX,MatrixY,FeldX,FeldY)
    Next
   Next
  Next
  For FeldNr=1 To MaxFelder
   Aus[FeldNr]=Aus[FeldNr]+"|"
   WriteLine FileNr,Aus[FeldNr]
   Aus[FeldNr]=""
  Next
 Next
 WriteLine FileNr,String$("+"+String$("-",MaxFelder*Abstand),MaxMatrix)+"+"
 CloseFile FileNr
End Function

Function GetFeld(MatrixX,MatrixY,FeldX,FeldY)
 Return Feld((MatrixX-1)*MaxFelder+FeldX,(MatrixY-1)*MaxFelder+FeldY)
End Function

Function SetFeld(MatrixX,MatrixY,FeldX,FeldY,Wert)
 Feld((MatrixX-1)*MaxFelder+FeldX,(MatrixY-1)*MaxFelder+FeldY)=Wert
End Function
Das große BlitzBasic Community Tutorial
Stackmaschine 2.0

SpionAtom

 BeitragSo, März 26, 2006 22:09
Antworten mit Zitat
Benutzer-Profile anzeigen
Was mir aufgefallen ist, dass deine Routine für ein richtiges Sudoku nicht ausreicht. Denn ein Sudoku ist immer lösbar und eindeutig. Das gewährleistet deine Routine nicht.

Ich hatte auch mal vor sowas zu programmieren, bin aber an eben dieser Hürde gescheitert. Crying or Very sad

Trotzdem weiterhin gutes Gelingen Surprised
os: Windows 10 Home cpu: Intel Core i7 6700K 4.00Ghz gpu: NVIDIA GeForce GTX 1080

Neue Antwort erstellen


Übersicht BlitzBasic Allgemein

Nach Oben

Gehe zu:

Powered by phpBB © 2001 - 2006, phpBB Group