' Sudoku-Generator
' (c) 2006 by Andreas Meile, CH-8242 Hofen SH

DECLARE SUB ZahlEinsetzen (e%)
DECLARE SUB LoeseSudoku (e%)

DIM SHARED f%(8, 8), fKa%(8, 8), keineL%
DIM SHARED sx%(80), sy%(80), aLue%, aLoe%

DIM aKa%(80), s%(9), sx1%(80), sy1%(80)

CLEAR , , 8000

' Schritt 1: gel�stes Sudoku generieren
RANDOMIZE TIMER

' Zu Beginn leeres Feld, Kandidaten vorbelegen
FOR y% = 0 TO 8
  FOR x% = 0 TO 8
    f%(x%, y%) = 0
    fKa%(x%, y%) = 1 + CINT(INT(9! * RND))
  NEXT x%
NEXT y%

SCREEN 0
' WIDTH 40, 25
CLS

t$ = ""
FOR i% = 1 TO 5
  READ h$
  t$ = t$ + h$
NEXT i%
DATA "���˻"
DATA "���׶"
DATA "�� ��"
DATA "���ι"
DATA "���ʼ"

' Felder zeichnen
COLOR 13
PRINT " Gel�stes             R�tsel"
PRINT " Sudoku               mit L�cken"
COLOR 7
FOR y% = 0 TO 18
  IF y% = 0 THEN
    ty% = 0
  ELSEIF y% = 18 THEN
    ty% = 4
  ELSEIF y% MOD 6 = 0 THEN
    ty% = 3
  ELSEIF y% MOD 2 = 0 THEN
    ty% = 1
  ELSE
    ty% = 2
  END IF
  FOR x% = 0 TO 18
    IF x% = 0 THEN
      tx% = 0
    ELSEIF x% = 18 THEN
      tx% = 4
    ELSEIF x% MOD 6 = 0 THEN
      tx% = 3
    ELSEIF x% MOD 2 = 0 THEN
      tx% = 1
    ELSE
      tx% = 2
    END IF
    LOCATE 3 + y%, 1 + x%
    PRINT MID$(t$, 1 + 5 * ty% + tx%, 1);
    LOCATE 3 + y%, 22 + x%
    PRINT MID$(t$, 1 + 5 * ty% + tx%, 1);
  NEXT x%
NEXT y%

' Generierprozess: Kandidaten einsetzen, bis Widerspruch entsteht oder L�sung
' gefunden

COLOR 14
keineL% = -1
ZahlEinsetzen 0

' Schritt 2: Felder leeren und schauen, ab wann das Sudoku uneindeutig wird
FOR i% = 0 TO 80
  x% = i% MOD 9
  y% = i% \ 9
  sx1%(i%) = x%
  sy1%(i%) = y%
  fKa%(x%, y%) = f%(x%, y%)
  LOCATE 4 + 2 * y%, 23 + 2 * x%
  PRINT CHR$(48 + f%(x%, y%));
NEXT i%
 
LOCATE 22, 22
PRINT "L�cken:  0 L�sungen: 0 Abbruch:  0"

aLue% = 0
h% = 0
WHILE h% < 20
  ' L�cken bilden: Diese per Zufall aus dem Rest "L�sli ziehen"
  i% = aLue% + CINT(INT(CSNG(81 - aLue%) * RND))
  IF i% > aLue% THEN
    SWAP sx1%(i%), sx1%(aLue%)
    SWAP sy1%(i%), sy1%(aLue%)
  END IF
  f%(sx1%(aLue%), sy1%(aLue%)) = 0
  LOCATE 4 + 2 * sy1%(aLue%), 23 + 2 * sx1%(aLue%)
  PRINT " ";
  aLue% = aLue% + 1
  LOCATE 22, 29
  PRINT USING "###"; aLue%;
  ' Kontrolle: Sudoku l�sen, dabei muss exakt 1 L�sung existieren
  aLoe% = 0
  COLOR 2
  LOCATE 22, 42
  PRINT " 0";
  ' Vorbereitung: Optimiersortierung
  FOR i% = 0 TO aLue% - 1
    sx%(i%) = sx1%(i%)
    sy%(i%) = sy1%(i%)
    s%(0) = 0
    FOR j% = 1 TO 9
      s%(j%) = -1
    NEXT j%
    aKa%(i%) = 9
    FOR j% = 0 TO 8
      ' Zeile
      IF s%(f%(j%, sy%(i%))) THEN
        aKa%(i%) = aKa%(i%) - 1
        s%(f%(j%, sy%(i%))) = 0
      END IF
      ' Spalte
      IF s%(f%(sx%(i%), j%)) THEN
        aKa%(i%) = aKa%(i%) - 1
        s%(f%(sx%(i%), j%)) = 0
      END IF
      ' 3x3-Unterquadrat
      IF s%(f%(3 * (sx%(i%) \ 3) + j% MOD 3, 3 * (sy%(i%) \ 3) + j% \ 3)) THEN
        aKa%(i%) = aKa%(i%) - 1
        s%(f%(3 * (sx%(i%) \ 3) + j% MOD 3, 3 * (sy%(i%) \ 3) + j% \ 3)) = 0
      END IF
    NEXT j%
  NEXT i%
  ' Sortieren
  FOR i% = 0 TO aLue% - 2
    FOR j% = i% + 1 TO aLue% - 1
      IF aKa%(i%) > aKa%(j%) THEN
        SWAP aKa%(i%), aKa%(j%)
        SWAP sx%(i%), sx%(j%)
        SWAP sy%(i%), sy%(j%)
      END IF
    NEXT j%
  NEXT i%
  LoeseSudoku 0
  COLOR 14
  IF aLoe% > 1 THEN
    ' R�tsel nicht mehr eindeutig => wieder einsetzen!
    aLue% = aLue% - 1
    LOCATE 22, 29
    PRINT USING "###"; aLue%;
    f%(sx1%(aLue%), sy1%(aLue%)) = fKa%(sx1%(aLue%), sy1%(aLue%))
    LOCATE 4 + 2 * sy1%(aLue%), 23 + 2 * sx1%(aLue%)
    PRINT CHR$(48 + f%(sx1%(aLue%), sy1%(aLue%)));
    h% = h% + 1
    LOCATE 22, 53
    PRINT USING "###"; h%;
  END IF
WEND

' R�tsel speichern

LOCATE 23, 1
INPUT "Sudoku-R�stel erstellt. Dateiname"; d$
OPEN d$ FOR OUTPUT AS 1
FOR i% = 0 TO 8
  FOR j% = 0 TO 8
    PRINT #1, CHR$(48 + f%(j%, i%));
  NEXT j%
  PRINT #1, ""
NEXT i%
CLOSE 1

SUB LoeseSudoku (e%)
  DIM s%(9)
  IF e% = aLue% THEN
    ' L�sung gefunden
    aLoe% = aLoe% + 1
    LOCATE 22, 42
    PRINT USING "##"; aLoe%;
  ELSE
    ' tempor�re Kandidatenliste
    FOR i% = 1 TO 9
      s%(i%) = -1
    NEXT i%
    ' Kandidaten streichen
    FOR i% = 0 TO 8
      ' Zeile
      s%(f%(i%, sy%(e%))) = 0
      ' Spalte
      s%(f%(sx%(e%), i%)) = 0
      ' 3x3-Unterquadrat
      s%(f%(3 * (sx%(e%) \ 3) + i% MOD 3, 3 * (sy%(e%) \ 3) + i% \ 3)) = 0
    NEXT i%
    ' Der Rest probeweise einmal einsetzen
    FOR i% = 1 TO 9
      IF s%(i%) AND aLoe% < 2 THEN
        LOCATE 4 + 2 * sy%(e%), 23 + 2 * sx%(e%)
        PRINT CHR$(48 + i%);
        f%(sx%(e%), sy%(e%)) = i%
        LoeseSudoku e% + 1
      END IF
    NEXT i%
    ' Feld wieder freigeben
    LOCATE 4 + 2 * sy%(e%), 23 + 2 * sx%(e%)
    PRINT " ";
    f%(sx%(e%), sy%(e%)) = 0
  END IF
END SUB

SUB ZahlEinsetzen (e%)
  DIM s%(9)

  IF e% = 81 THEN
    ' Feld gef�llt
    keineL% = 0
  ELSE
    x% = e% MOD 9
    y% = e% \ 9
    ' M�gliche Kandidaten bestimmen
    FOR i% = 1 TO 9
      s%(i%) = -1
    NEXT i%
    ' Kandidaten streichen
    FOR i% = 0 TO 8
      ' Zeile
      s%(f%(i%, y%)) = 0
      ' Spalte
      s%(f%(x%, i%)) = 0
      ' 3x3-Unterquadrat
      s%(f%(3 * (x% \ 3) + i% MOD 3, 3 * (y% \ 3) + i% \ 3)) = 0
    NEXT i%

    FOR i% = 1 TO 9
      IF s%(fKa%(x%, y%)) AND keineL% THEN
        ' Kandidat passt => probeweise einsetzen
        f%(x%, y%) = fKa%(x%, y%)
        LOCATE 4 + 2 * y%, 2 + 2 * x%
        PRINT CHR$(48 + f%(x%, y%));
        ZahlEinsetzen e% + 1
      END IF
      ' erh�hen
      fKa%(x%, y%) = fKa%(x%, y%) + 1
      IF fKa%(x%, y%) > 9 THEN
        fKa%(x%, y%) = 1
      END IF
    NEXT i%
    ' Wieder herausnehmen
    IF keineL% THEN
      f%(x%, y%) = 0
      LOCATE 4 + 2 * y%, 2 + 2 * x%
      PRINT " ";
    END IF
  END IF
END SUB