PureBoard

Verfasst: **05.11.2006 23:06**

Guten Tag,

genau solch einen Code habe ich geschrieben, jedoch muss noch ein Fehler drin sein, denn manchmal klappt es nicht, ein Rätsel zu erzeugen und das Programm bleibt irgendwo hängen. Erstmal zum groben Ablauf des Algorithmus (zum späteren Verständnis meines Codes): Um das Sudoku-Rätsel zu erzeugen, wird der Reihe nach (Zeilenweise von oben nach unten und von links nach rechts) jede Zelle des 9x9 Felder großen Rätsels mit einer Ziffer befüllt. Dabei wird eine zufällige Zahl zwischen 1 und 9 erzeugt und eingetragen. Kommt es durch diese Zahl zu einem Regelverstoß, wird eine andere probiert. Bei Erfolg geht's zur nächsten Zelle und wenn keine Zahl mehr passt, dann wird eine Zelle zurückgegangen und in dieser eine neue, zuvor noch nicht probierte Zahl, eingetragen. Für jede Zelle gibt es einen String, in welchem die bereits probierten Zahlen gelöscht werden.
Letztlich ergibt sich ein vollständig gefülltes Zahlengitter aus welchem anschließend einige Zahlen wieder entfernt werden.

Die Routine, die für das Entfernen der Zahlen zuständig ist, scheint zu funktionieren. Beim Debuggen hängt er dort nie drin, wenn's mal wieder hängengeblieben ist. Das Problem muss in der/den anderen Programmroutinen stecken.

Wäre jemand so nett und würde meinen Code mal auf dieses Problem hin untersuchen? Ich weiß, dass dies eigentlich schon eine Zumutung ist aber vielleicht hat jemand zufällig Lust, sich damit zu befassen. Ich kann den Fehler einfach nicht finden.

Vielen Dank schonmal im Voraus.

Code: Alles auswählen

Global Dim Matrix.l(9,9),Dim FreeNumbers.s(81),CellX.b,CellY.b,SquareX.b,SquareY.b

;Matrix           = speichert die Ziffern des 9x9 Felder großen Puzzles.
;FreeNumbers      = jeder String enthält die für die entsprechende Zelle noch zur Verfügung
;                   stehenden Ziffern
;CellX,CellY      = aktuelle Position im 9x9er Puzzle (Zeile, Spalte)
;SquareX,SquareY  = Zeile und Spalte der oberen linken Ecke des aktuellen 3x3er Miniquadrats

Procedure SetValues() ;Setzen der Ausgangswerte für die Erstellung eines neuen Puzzles
  For a=1 To 9
    For b=1 To 9
      Matrix(a,b)=0
      FreeNumbers(a*b)="123456789"
    Next
  Next
  CellX=1
  CellY=1
  SquareX=1
  SquareY=1
EndProcedure

Procedure.b Legality()  ;Prüfen, ob die zuletzt eingetragene Ziffer einen Regelverstoß verursacht
  Result.b=1
  For a=1 To 9
    String1$=String1$+Str(Matrix(CellX,a))
    String2$=String2$+Str(Matrix(a,CellY))
  Next
  If CountString(String1$,Str(Matrix(CellX,CellY)))>1 Or CountString(String2$,Str(Matrix(CellX,CellY)))>1
    Result=0
  EndIf
  For a=1 To 3
    For b=1 To 3
      String$=String$+Str(Matrix(SquareX+a-1,SquareY+b-1))
    Next
  Next
  If CountString(String$,Str(Matrix(CellX,CellY)))>1
    Result=0
  EndIf
  ProcedureReturn Result
EndProcedure

Procedure DetectSquare()    ;Anhand von Zeilen- und Spaltenposition (CellX, CellY) ermitteln, in
  Select CellX              ;welchem 3x3er Miniquadrat sich die aktualle Zelle befindet und die
    Case 1 To 3             ;Zeilen- und Spaltenposition dessen setzen.
      SquareX=1
    Case 4 To 6
      SquareX=4
    Default
      SquareX=7
  EndSelect
  Select CellY
    Case 1 To 3
      SquareY=1
    Case 4 To 6
      SquareY=4
    Default
      SquareY=7
  EndSelect
EndProcedure

Procedure PreviousStep()
  If CellY>1
    CellY=CellY-1
  Else
    CellY=9
    CellX=CellX-1
  EndIf
  DetectSquare()
EndProcedure

Procedure NextStep()
  If CellY<9
    CellY=CellY+1
  Else
    CellY=1
    CellX=CellX+1
  EndIf
  DetectSquare()
EndProcedure

Procedure GenerateNumber()        ;Erzeugen einer zufälligen Zahl zwischen 1 und 9, um diese in
  Repeat                          ;die aktuelle Zelle einzusetzen. Bei Regelverstoß die nächste
    If FreeNumbers(CellX*CellY)="" ;noch nicht probierte Ziffer einsetzen und bei Erfolg in die
      Matrix(CellX,CellY)=0        ;nächste Zelle gehen. Wenn keine Ziffer passt, eine Zelle zurück.
      FreeNumbers(CellX*CellY)="123456789"
      PreviousStep()
      Break
    EndIf
    Matrix(CellX,CellY)=Val(Mid(FreeNumbers(CellX*CellY),Random(Len(FreeNumbers(CellX*CellY))-1)+1,1))
    FreeNumbers(CellX*CellY)=RemoveString(FreeNumbers(CellX*CellY),Str(Matrix(CellX,CellY)))
    If Legality()=1
      NextStep()
      Break
    EndIf
  ForEver
EndProcedure

Procedure.b CheckRows()     ;Überprüfen, wieviele Zahlen sich noch in der Zeile und Spalte der
  Result.b=0                 ;Zelle befinden, aus welcher eine Zahl entfernt werden soll.
  For a=1 To 9
    String1$=String1$+Str(Matrix(CellX,a))
    String2$=String2$+Str(Matrix(a,CellY))
    String3$=String3$+Str(Matrix(5+(5-CellX),a))
    String4$=String4$+Str(Matrix(a,5+(5-CellY)))
  Next
  If CountString(String1$,"0")<5 Or CountString(String2$,"0")<5 Or CountString(String3$,"0")<5 Or CountString(String4$,"0")<5
    Result=1
  EndIf
  ProcedureReturn Result
EndProcedure

Procedure RemoveNumbers()           ;Entfernen von Zahlen aus dem fertigen Puzzle in einem
  NumbersToRemove.b=Random(12)+45    ;symmetrischen Verfahren
  NumbersRemoved.b=0
  Counter.w=0
  Repeat
    Counter=Counter+1
    If Counter>10000:Break:EndIf
    CellX=Random(8)+1
    CellY=Random(8)+1
    If Matrix(CellX,CellY)<>0 And CheckRows()=1
      Matrix(CellX,CellY)=0
      Matrix(5+(5-CellX),5+(5-CellY))=0
      If CellX=5 And CellY=5
        NumbersRemoved=NumbersRemoved+1
      Else
        NumbersRemoved=NumbersRemoved+2
      EndIf
    EndIf
  Until NumbersRemoved>NumbersToRemove
EndProcedure

Procedure CreateOutputImage()     ;Das Rätsel in ein Bild zeichnen und dieses anschließend öffnen
  CreateImage(0,288,288,24)
  LoadFont(0,"Arial",16,#PB_Font_Bold)
  StartDrawing(ImageOutput(0))
    Box(0,0,288,288,$FFFFFF)
    Box(8,8,90,90,$FFFFFF)
    Box(188,8,90,90,$FFFFFF)
    Box(98,98,90,90,$FFFFFF)
    Box(8,188,90,90,$FFFFFF)
    Box(188,188,90,90,$FFFFFF)
    Box(98,8,90,90,$EEEEEE)
    Box(8,98,90,90,$EEEEEE)
    Box(188,98,90,90,$EEEEEE)
    Box(98,188,90,90,$EEEEEE)
    DrawingMode(#PB_2DDrawing_Outlined)
    For a=0 To 2
      For b=0 To 2
        For c=7 To 9
          Box(a*90+c,b*90+c,91,91,$000000)
        Next
      Next
    Next
    For a=0 To 8
      For b=0 To 8
        Box(a*30+8,b*30+8,31,31,$000000)
      Next
    Next
    DrawingFont(FontID(0))
    DrawingMode(#PB_2DDrawing_Transparent)
    For a=0 To 8
      For b=0 To 8
        If Matrix(a+1,b+1)>0
          DrawText(b*30+17,a*30+12,Str(Matrix(a+1,b+1)))
        EndIf
      Next
    Next
  StopDrawing()
  SaveImage(0,"Sudoku.bmp")
  RunProgram("Sudoku.bmp")
EndProcedure

Procedure CreatePuzzle()
  SetValues()
  Repeat
    GenerateNumber()
    If CellX>9:Break:EndIf
  ForEver
  RemoveNumbers()
  CreateOutputImage()
EndProcedure

CreatePuzzle()

Verfasst: **06.11.2006 01:06**

hab mir das jetzt nicht genau angeschaut, mir ist nur folgendes aufgefallen: FreeNumbers(CellX*CellY)
dazu zwei fälle:
CellX=2
CellY=3
CellX*CellY=6

CellX=3
CellY=2
CellX*CellY=6

obwohl in beiden fällen verschiedene felder gemeint sind, wird ein und der selbe string verarbeitet. wenn es für jedes feld einen string gibt, würde ich das auch hier mit einem 2 dimensionalen array machen:
DIM FreeNumbers.s(9,9)
oder wie jetzt mit einem 1 dimensionalen array, dann aber so:
FreeNumbers(CellX+(CellY-1)*9)

hab aber nicht überprüft ob das die ursache für dein prob war.

Verfasst: **06.11.2006 11:03**

Hi, da bin ich wieder.

KeyPusher, ich bin dir zu Dank verpflichtet! Denn deine Vermutung ist richtig. Mit einem 2 dimensionalen Array für FreeNumbers läuft die Sache nun perfekt. Jetzt ist es mir schon fast peinlich, dieses Problem hier ins Forum gepostet zu haben. Ein solch logischer Fehler und den habe ich nicht erkannt.

Wahrscheinlich ist es manchmal gut, andere etwas betrachten zu lassen, denn die sehen noch viel mehr das Gesamte, während man selbst einen schon viel zu "engen" Blick dafür hat.

Also besten Dank, dass du es dir angeschaut hast.

Verfasst: **06.11.2006 17:29**

Super! So einen Code hab ich schon lange gesucht!

(Ich hatte nur 4x4-Sudokus geschafft

)

PureBoard

Code, um Sudoku-Rätsel zu erzeugen

Code, um Sudoku-Rätsel zu erzeugen