Graphics 400,400,32,2
SetBuffer BackBuffer()

SeedRnd MilliSecs()

Dim map(9,9,1) ;(x,y,[0=Zahlenwert;1=fest oder nicht festes Feld])
Dim z(10)

Global font = LoadFont("Arial",36)
Global gw#=GraphicsWidth(),gh#=GraphicsHeight(),count

SetFont font
ClsColor 255,255,255 : Cls
Color 0,0,0

t1 = MilliSecs()
count=0
Generate()
t1 = MilliSecs()-t1
DebugLog "Fertig: "+count +" "+ t1+"ms"

Repeat
   Cls
   Draw(0)
   Control()
   Flip
Until KeyHit(1)

;-------Funktionen----------
;Steuerung
Function Control()
   mx = Floor(MouseX()/(gw/9))+1
   my = Floor(MouseY()/(gh/9))+1
   If MouseHit(2) Then
      map(mx,my,0)=map(mx,my,0)+1
      map(mx,my,1)=1
      
      If map(mx,my,0) =10 Then
         map(mx,my,0)=0
         map(mx,my,1)=0
      EndIf
   EndIf
   If MouseHit(1) Then
      If map(mx,my,1) = 0 Then
         map(mx,my,0)=map(mx,my,0)+1
      
         If map(mx,my,0) =10 Then
            map(mx,my,0)=0
         EndIf
      EndIf
   EndIf
   If KeyHit(59) Then Solve()
   If KeyHit(60) Then Clear()
End Function

;Zeichnen
Function Draw(mode)
   Color 0,0,0
   For x = 0 To 8
      For y = 0 To 8
         If map(x+1,y+1,1) = 1 Then
            If mode = 0 Then
               Color 230,230,230
            Else
               Color 130,130,130
            EndIf
            Rect x*gw/9+1,y*gh/9+1,gw/9,gh/9,1
            Color 0,0,0
         EndIf
      Next
   Next
   
   If mode = 0 Then
      Color 200,240,200
      Rect Floor(MouseX()/(gw/9))*(gw/9),Floor(MouseY()/(gh/9))*(gh/9),gw/9+1,gh/9+1,1
   EndIf
   
   Color 0,0,0
   For x = 0 To 8
      For y = 0 To 8
         If map(x+1,y+1,0) <> 0 Then Text x*gw/9+(gw/30),y*gh/9+(gh/80),map(x+1,y+1,0)
      Next
   Next   
   
   For i= 1 To 9
      If i Mod 3 = 0 Then
         Rect i*(gh/9.0)-1,0,3,gh
         Rect 0,i*(gh/9.0)-1,gw,3
      Else
         Rect 0,i*(gh/9.0),gw,1
         Rect i*(gh/9.0),0,1,gh
      EndIf      
   Next
End Function

;Neues Sudoku generieren
Function Generate()
   ClsColor 195,195,195 : Cls
   ;Solange Wiederholen, bis keine Lösung mehr möglich
   Repeat
      Clear()
      Cls : Draw(1) : Flip
      
       count=count+1
      ;Per Zufall ein Feld bestimmen
      Repeat
         x = Rand(1,9) : y = Rand(1,9)
      Until map(x,y,0) = 0
      
      ;einen zufälligen Wert für das Feld bestimmen
      map(x,y,0) = Rand(1,9) : t=0
      
      ;Wenn der Wert nicht den Regeln entspricht, diesen um eins erhöhen
      While CheckField(x,y) = 1 And t<>10
         t=t+1
         map(x,y,0) = map(x,y,0) +1
         If map(x,y,0) = 10 Then map(x,y,0) = 1
      Wend
      
      ;Aktuelle Feld "fest" machen
      map(x,y,1) = 1
      lx = x
      ly = y
   Until solve()=0
   ;Letzte änderung rückgängig machen
   map(lx,ly,1) = 0 : count =count - 1 : Clear()
   
   ;Wenn noch keine 30 Felder erreicht wurden wird diese Funtion nochmal aufgerufen
   If count < 30 Then generate()
   ClsColor 255,255,255 : Cls
End Function

;Sudoku lösen
Function Solve()
   t1 = MilliSecs() : s=1
   ;nicht feste Zahlen löschen
   Clear()
   
   ;Überprüfen ob die festen Zahlen den Regeln entsprechen
   For x=1 To 9
      For y=1 To 9
         If map(x,y,1) = 1 Then
            If CheckField(x,y) = 1 Then s=0
         EndIf
      Next
   Next
      
   ;Die anderen Zahlen überprüfen, wenn die festen Zahlen den Regeln entsprechen
   If s = 1 Then
      ;Alle Felder durchgehen
      For i = 1 To 81
         ;Wenn es keine Lösung gibt oder zuviel Zeit benötigt wurde
         If i<1 Or MilliSecs()-t1 > 150 Then s = 0 : Clear : Exit
         
         ;X/Y werte berechnen
         y=Ceil(Float(i)/9.0)
         x=((i-1) Mod 9)+1
      
         ;Wenn die aktuelle Position keine feste Zahl ist
         If map(x,y,1) = 0 Then
            ;Zahlen von 1 - 10 einsetzen und überprüfen
            Repeat
               map(x,y,0) = map(x,y,0) + 1
            Until CheckField(x,y) = 0 Or map(x,y,0) = 10
            ;Wenn keine Zahl passt
            If map(x,y,0)=10  Then
               ;Wert zurück auf 0 setzen
               map(x,y,0) = 0
               ;zur letzten nicht festen Position zurückgehen und i um eins zurücksetzen
               Repeat
                  i=i-1
                  y=Ceil(Float(i)/9.0)
                  x=((i-1) Mod 9)+1
               Until map(x,y,1)=0
               i=i-1
            EndIf
         EndIf
      Next
   EndIf

   t1 = MilliSecs()-t1
   DebugLog t1 + "ms | Lösbar: " + s
   Return s
End Function

;Funktion zum Prüfen ob ein Feld den Regeln entspricht. (Wird zum lösen benötigt)
Function CheckField(x,y)
   fail = 0
   ;Horizontal
   For i=1 To 9
      z(map(x,i,0))=z(map(x,i,0))+1
   Next
   fail = fail + ZArrayCheck()
   
   ;Vertikal
   For i=1 To 9
      z(map(i,y,0))=z(map(i,y,0))+1
   Next
   fail = fail + ZArrayCheck()
   
   ;3*3 Block
   For x1 = 1 To 3
      For y1 = 1 To 3
         z(map((((x-1)/3))*3+x1,(((y-1)/3))*3+y1,0))=z(map((((x-1)/3))*3+x1,(((y-1)/3))*3+y1,0))+1
      Next
   Next
   fail = fail + ZArrayCheck()
   
   If fail <> 0 Then fail=1
   
   Return fail
End Function

;Funtion um den Zahlenarray zu überprüfen und zu säubern. (Wird für die Funktion CheckField() benötigt)
Function ZArrayCheck()
   fail=0
   For i=1 To 9
      If z(i) > 1 Then fail=fail+1
      z(i) = 0
   Next
   Return fail
End Function

;Löscht alle nicht-festen Zahlen aus dem Sudoku
Function Clear()
   For x =1 To 9
      For y = 1 To 9
         If map(x,y,1) = 0 Then map(x,y,0) = 0
      Next
   Next
End Function

;Löscht alle Zahlen aus dem Sudoku
Function Del()
   For x =1 To 9
      For y = 1 To 9
         map(x,y,0) = 0
         map(x,y,1) = 0
      Next
   Next
End Function