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

Dim sudoku(8,8,1) ;speichert das Sudoku, 0:werte,1:fest oder nicht
Global ready      ;Sudoku ist fertig gelöst oder nicht
Global drawmode=0 ;0:garnicht,1:immer wenn neuer richtiger wert,2:immer



;laden
Restore feld
For zy=0 To 8
   For zx=0 To 8
   Read sudoku(zx,zy,0)
   If sudoku(zx,zy,0)<>0 Then sudoku(zx,zy,1)=1
   Next
Next
;ausgeben
draw()

;Lösen
If check(0,0) Then RuntimeError("unlösbar")
;ausgeben
Repeat
draw()
Until KeyHit(1)
End


Function check(x,y)
   Local val,a

   ;berechnen der korrekten x position
   If x>8 Then x=0:y=y+1
   ;weitergehen zum nächsten freien kästchen
   While sudoku(x,y,1)=1
      x=x+1
      If x>8 Then
         y=y+1:x=0
         If y>8 Then ready=1:Return False
      EndIf    
   Wend

   ;kästchen füllen
   For val=1 To 9
      DebugLog("x:"+x+" / y:"+y+"   tested: "+val)
      sudoku(x,y,0)=val
      If drawmode=2 Then draw()
      ;If nrone Then Stop
      If fit(x,y,val) Then ;falls der Wert passt
         If drawmode=1 Then draw()
         If x=8 And y=8 Then
            ready=1
            Return False ;wenn letztes kästchen beenden
         EndIf    
         a=check(x+1,y) ;nächstes kästchen checken
         If Not a Then Return False ;wenn "endmessage" kommt beenden
      EndIf    
   
   Next
   ;wenn keine lösung beenden ->letztes kästchen kriegt anderen wert
   sudoku(x,y,0)=0
   Return True   
End Function


   

Function fit(x,y,val);gibt zurück, ob eine zahl in ein kästchen passt

   Local startx,starty,tx,ty
   
   
   ;waagerechte übereinstimmungen suchen
   For tx=0 To 8
      If sudoku(tx,y,0)=val And tx<>x Then DebugLog "waag "+tx:Return False
   Next
   ;senkrecht übereinstimmungen suchen
   For ty=0 To 8
      If sudoku(x,ty,0)=val And ty<>y Then DebugLog "senk "+ty:Return False
   Next
   
   ;in den kästchen übereinstimmungen suchen

   If x<3 And y<3                Then startx=0:starty=0
   If x>2 And x<6 And y<3         Then startx=3:starty=0
   If x>5 And y<3               Then startx=6:starty=0
   If x<3 And y>2 And y<6          Then startx=0:starty=3
   If x>2 And x<6 And y>2 And y<6  Then startx=3:starty=3
   If x>5 And y>2 And y<6          Then startx=6:starty=3
   If x<3 And y>5                Then startx=0:starty=6
   If x>2 And x<6 And y>5          Then startx=3:starty=6
   If x>5 And y>5              Then startx=6:starty=6
   
   For tx=0 To 2
      For ty=0 To 2
         If sudoku(tx+startx,ty+starty,0)=val And tx+startx<>x And ty+starty<>y Then DebugLog("kästchen"):Return False
      Next
   Next   

   ;wenn keine übereinstimmung gefunden

   Return True
   
End Function


Function draw()
   Local zx,zy
   Cls
   For zy=0 To 8
      For zx=0 To 8
         Color 200,0,0
         If ready          Then Color 0,200,0
         If sudoku(zx,zy,1) Then Color 0,0,200         
         If sudoku(zx,zy,0) <> 0 Then
            Text 5+zx*20,3+zy*20,sudoku(zx,zy,0)
         Else
            Text 5+zx*20,3+zy*20,"X"
         EndIf       
      Next
   Next
   Flip 0
End Function   


.feld
;sudoku von wikipedia
Data 5,3,0,0,7,0,0,0,0
Data 6,0,0,1,9,5,0,0,0
Data 0,9,8,0,0,0,0,6,0
Data 8,0,0,0,6,0,0,0,3
Data 4,0,0,8,0,3,0,0,1
Data 7,0,0,0,2,0,0,0,6
Data 0,6,0,0,0,0,2,8,0
Data 0,0,0,4,1,9,0,0,5
Data 0,0,0,0,8,0,0,7,9

;sudoku von http://sudoku.zeit.de/sudoku/kunden/die_zeit/
Data 0,0,0,3,7,0,0,0,0
Data 0,5,0,0,0,0,1,3,4
Data 3,9,6,0,0,0,2,0,8
Data 6,0,1,0,0,0,7,0,0
Data 0,0,0,5,0,0,3,0,0
Data 0,3,7,8,9,1,4,0,0
Data 0,0,4,1,0,0,0,0,3
Data 0,6,0,0,4,2,0,0,9
Data 2,0,0,0,0,3,6,0,0

;------------------------------------------------------------------------------------
;INFORMATION
;
;An gewünschter Stelle die Maus gedrückt halten und die
;vom Sudoku vorgegebenen Zahlen eingeben (0 wird zu X).
;Enter drücken, Sudoku wird gelöst.
;
;Rote X: Nicht vorgegebene Zahlen
;Blaue Zahlen: Vorgegebene Zahlen
;Grüne Zahlen: Ermittelte Zahlen
;------------------------------------------------------------------------------------

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

Dim sudoku(8,8,1) ;speichert das Sudoku, 0:werte,1:fest oder nicht
Global ready ;Sudoku ist fertig gelöst oder nicht
Global drawmode=0 ;0:garnicht,1:immer wenn neuer richtiger wert,2:immer


Repeat
mx = MouseX():my=MouseY()
If MouseDown(1) Then
Taste = GetKey()
If Taste >= 48 And Taste <= 57 Then
Sudoku(Floor(mx/20),Floor(my/20),0) = Taste-48
Sudoku(Floor(mx/20),Floor(my/20),1) = 1
EndIf
EndIf

For i = 0 To 8
For j = 0 To 8
If sudoku(i,j,0) = 0 Then sudoku(i,j,1) = 0
Next
Next
draw()
Until KeyHit(28)

;Lösen
If check(0,0) Then RuntimeError("unlösbar")
;ausgeben
Repeat
draw()
Until KeyHit(1)
End


Function check(x,y)
Local val,a

;berechnen der korrekten x position
If x>8 Then x=0:y=y+1
;weitergehen zum nächsten freien kästchen
While sudoku(x,y,1)=1
x=x+1
If x>8 Then y=y+1:x=0
Wend

;kästchen füllen
For val=1 To 9
DebugLog("x:"+x+" / y:"+y+" tested: "+val)
sudoku(x,y,0)=val
If drawmode=2 Then draw()
If fit(x,y,val) Then ;falls der Wert passt
If drawmode=1 Then draw()
If x=8 And y=8 Then
ready=1
Return False ;wenn letztes kästchen beenden
EndIf
a=check(x+1,y) ;nächstes kästchen checken
If Not a Then Return False ;wenn "endmessage" kommt beenden
EndIf

Next
;wenn keine lösung beenden ->letztes kästchen kreigt anderen wert
sudoku(x,y,0)=0
Return True
End Function




Function fit(x,y,val);gibt zurück, ob eine zahl in ein kästchen passt

Local startx,starty,tx,ty


;waagerechte übereinstimmungen suchen
For tx=0 To 8
If sudoku(tx,y,0)=val And tx<>x Then DebugLog "waag "+tx:Return False
Next
;senkrecht übereinstimmungen suchen
For ty=0 To 8
If sudoku(x,ty,0)=val And ty<>y Then DebugLog "senk "+ty:Return False
Next

;in den kästchen übereinstimmungen suchen

If x<3 And y<3 Then startx=0:starty=0
If x>2 And x<6 And y<3 Then startx=3:starty=0
If x>5 And y<3 Then startx=6:starty=0
If x<3 And y>2 And y<6 Then startx=0:starty=3
If x>2 And x<6 And y>2 And y<6 Then startx=3:starty=3
If x>5 And y>2 And y<6 Then startx=6:starty=3
If x<3 And y>5 Then startx=0:starty=6
If x>2 And x<6 And y>5 Then startx=3:starty=6
If x>5 And y>5 Then startx=6:starty=6

For tx=0 To 2
For ty=0 To 2
If sudoku(tx+startx,ty+starty,0)=val And tx+startx<>x And ty+starty<>y Then DebugLog("kästchen"):Return False
Next
Next

;wenn keine übereinstimmung gefunden

Return True

End Function


Function draw()
Local zx,zy
Cls
For zy=0 To 8
For zx=0 To 8
Color 200,0,0
If ready Then Color 0,200,0
If sudoku(zx,zy,1) Then Color 0,0,200
If sudoku(zx,zy,0) <> 0 Then
Text 5+zx*20,3+zy*20,sudoku(zx,zy,0)
Else
Text 5+zx*20,3+zy*20,"X"
EndIf
Next
Next
Flip 0
End Function

function Possibilities(feld:tSudoku; pos: tPosition; Zahl: Integer):Bool;
var I,J,A,B,C,D: Integer;
begin
  Result:=True;
  for I:=1 to 9 do
  begin
    if feld[pos[1],I]=Zahl then Result:=False;
    if feld[I,pos[2]]=Zahl then Result:=False;
  end;
  If pos[1]<=3 then
  begin
    A:=1;
    B:=3;
  end;
  If (pos[1]>=4) and (pos[1]<=6) then
  begin
    A:=4;
    B:=6;
  end;
  If pos[1]>=7 then
  begin
    A:=7;
    B:=9;
  end;
  If pos[2]<=3 then
  begin
    C:=1;
    D:=3;
  end;
  If (pos[2]>=4) and (pos[2]<=6) then
  begin
    C:=4;
    D:=6;
  end;
  If pos[2]>=7 then
  begin
    C:=7;
    D:=9;
  end;
  for I:=A to B do
  begin
    for J:=C to D do
    begin
      If feld[I,J]=Zahl then Result:=False;
    end;
  end;
end;

function NextPosition(feld: tSudoku): tPosition;
var I,J: Integer;
begin
  for I:=1 to 9 do
  begin
    for J:=1 to 9 do
    begin
      If feld[I,J]=0 then
      begin
        Result[1]:=I;
        Result[2]:=J;
        Exit;
      end;
    end;
  end;
  Result[1]:=0;
  Result[2]:=0;
end;

function Loesen(feld: tSudoku):bool;
var workfield: tSudoku;
    position: tPosition;
    moeglichkeit: tPossibilities;
    I: Integer;
    Ausgabe: bool;
    antwort: word;
begin
  Result:=False;
  workfield:=feld;
  position:=NextPosition(workfield);

  current_time:=MilliSecondOfTheDay(Time());
  If current_time-start_time>=2000 then
  begin
    abbruch:=True;
    antwort:=MessageDlg('Achtung: Die Berechnung dauert zu lange, das eingebene SuDoKu Rätsel hat wahrscheinlich keine gültige Lösung!',mtWarning,[mbAbort,mbRetry],0);
    if antwort=mrRetry then
    begin
      abbruch:=False;
      start_time:=MilliSecondOfTheDay(Time());
    end;
    if antwort=mrAbort then
    begin
      abbruch:=True;
      Result:=True;
      Exit;
    end;
  end;

  if (position[1]=0) and (position[2]=0) then
  begin
    Result:=True;
    fertiges_feld:=workfield;
    Exit;
  end;

  for I:=1 to 9 do
  begin
    moeglichkeit[I]:=Possibilities(workfield,position,I);
  end;

  for I:=1 to 9 do
  begin
    if moeglichkeit[I]=True then
    begin
      workfield[position[1],position[2]]:=I;
      Ausgabe:=Loesen(workfield);
      if (Ausgabe=True) or (abbruch=True) then
      begin
        Result:=True;
        Exit;
      end;
    end;
  end;

end;