sudoku-löser
Übersicht
BlitzBasic Codearchiv
|
SmilyBetreff: sudoku-löser |
 Di, Jul 10, 2007 22:45Antworten mit Zitat 
|
|---|---|---|
|
Hallo,
Ich hab mich mal an einem Sudoku-löser versucht. Und folgendes kam raus: Bedienung: Linke Maustaste = feld + 1 Rechte Maustaste = feld - 1 Mittlere Maustaste = feld lösen (Prüfen ob nur eine zahl reinpasst -> Wenn ja zahl eintragen) Leertaste = Alle felder lösen Code: [AUSKLAPPEN] Graphics 320,320,16,2
ClsColor 255,255,255 Dim feld(2,2,2,2) SetFont LoadFont("arial", 20,1) SetBuffer BackBuffer() Repeat Cls For x = 0 To 8 For y = 0 To 8 x1 = floor(x/3) y1 = Floor(y/3) x2 = x Mod 3 y2 = y Mod 3 If RectsOverlap(mousex(),mousey(),1,1,20+x*30,20+y*30,30,30) Color 200,255,200 Rect 20+x*30,20+y*30,30,30 If MouseHit(1) feld(x1,y1,x2,y2) = feld(x1,y1,x2,y2) + 1 If MouseHit(2) feld(x1,y1,x2,y2) = feld(x1,y1,x2,y2) - 1 If MouseHit(3) feld(x1,y1,x2,y2) = make(x1,y1,x2,y2) feld(x1,y1,x2,y2) = (feld(x1,y1,x2,y2) + 10) Mod 10 End If Color 0,0,0 If feld(x1,y1,x2,y2) Text 35+x*30,35+y*30,feld(x1,y1,x2,y2),1,1 Next next For x = 0 To 9 If x Mod 3 Color 200,200,200 Else Color 0,0,0 Line 20 + x*30,20,20+x*30,290 Next For y = 0 To 9 If y Mod 3 Color 200,200,200 Else Color 0,0,0 Line 20,20 + y*30,290,20+y*30 Next If KeyHit(14) For x = 0 To 8 For y = 0 To 8 x1 = floor(x/3) y1 = Floor(y/3) x2 = x Mod 3 y2 = y Mod 3 feld(x1,y1,x2,y2) = 0 Next next End if If KeyHit(57) repeat c = 0 For x = 0 To 8 For y = 0 To 8 x1 = floor(x/3) y1 = Floor(y/3) x2 = x Mod 3 y2 = y Mod 3 If Not feld(x1,y1,x2,y2) z = make(x1,y1,x2,y2) If z>0 feld(x1,y1,x2,y2) = z: c = c +1 End if Next Next Until c = 0 End if flip Until KeyHit(1) Function make(x1,y1,x2,y2) tmp = feld(x1,y1,x2,y2) Local check[9] For x = 0 To 2 For y = 0 To 2 check[feld(x1,y1,x,y)] = 1 Next Next For cx1 = 0 To 2 For cx2 = 0 To 2 check[feld(cx1,y1,cx2,y2)]=1 Next Next For cy1 = 0 To 2 For cy2 = 0 To 2 check[feld(x1,cy1,x2,cy2)]=1 Next Next feld(x1,y1,x2,y2) = tmp count = 0 For x = 1 To 9 count = count + check[x] If check[x] = 0 ret = x Next If count = 8 Return ret End function |
||
|
Lesestoff:
gegen Softwarepatente | Netzzensur | brain.exe | Unabhängigkeitserklärung des Internets "Wir müssen die Rechte der Andersdenkenden selbst dann beachten, wenn sie Idioten oder schädlich sind. Wir müssen aufpassen. Wachsamkeit ist der Preis der Freiheit --- Keine Zensur!" stummi.org |
||
- Zuletzt bearbeitet von Smily am Mi, Jul 11, 2007 11:21, insgesamt einmal bearbeitet
Krümel |
Mi, Jul 11, 2007 0:42 Antworten mit Zitat
|
|
|---|---|---|
Bei mir löst es sich nicht, es tut sich garnix 
|
||
|
PowerProgrammer |
Mi, Jul 11, 2007 9:37 Antworten mit Zitat
|
|---|---|---|
Toll toll. Sieht nicht schlecht aus. Ich habe mal das Wikipedia-Sudoku eingetragen, aber das hat dein Programm nur soweit gelöst:
Das hat Stil. |
||
| www.xairro.com Alles für Webmaster und Programmierer! Es gibt mehr als bloß einen Counter! | ||
|
|
Smily |
Mi, Jul 11, 2007 11:14 Antworten mit Zitat
|
|---|---|---|
|
Ich hatte das programm eigentlich am Wikipedia-Sudoku getestet ^^
Du hast das Sudoku von Wikipedia falsch übertragen. im Unteren rechten 3x3er-feld die zahl oben in der mitte muss keine 6 sondern eine 8 sein 
Damit hast du dem Programm eine unlösbare aufgabe Gestellt. mfg, Smily0412 |
||
|
Lesestoff:
gegen Softwarepatente | Netzzensur | brain.exe | Unabhängigkeitserklärung des Internets "Wir müssen die Rechte der Andersdenkenden selbst dann beachten, wenn sie Idioten oder schädlich sind. Wir müssen aufpassen. Wachsamkeit ist der Preis der Freiheit --- Keine Zensur!" stummi.org |
||
|
|
PowerProgrammer |
Mi, Jul 11, 2007 12:15 Antworten mit Zitat
|
|---|---|---|
|
Upps, na dann^^
Aber dein Code ist wirklich nicht schlecht, nettes Programm. |
||
| www.xairro.com Alles für Webmaster und Programmierer! Es gibt mehr als bloß einen Counter! | ||
Krümel |
Mi, Jul 11, 2007 21:12 Antworten mit Zitat
|
|
|---|---|---|
|
Ah, jetzt hab ichs auch zum Laufen bekommen...
Anscheinend war das Sudoku mit dem ich dein Programm gefüttert habe zu schwierig. Vor längerer Zeit habe ich mal einen Sudokulöser geschrieben, der nur aufgrund von Logik funktioniert. Ich wende 4 simple Regeln an, mit denen man selbst schwerste Sudokus lösen kann. (In sehr kurzer Zeit) Hier ist der Code: Code: [AUSKLAPPEN] Graphics 700,680,16,2 SetBuffer BackBuffer() SetFont LoadFont("",25) Dim Feld$(9,9),nr(9,9) Restore dSudoku For y=0 To 8 For x=0 To 8 Read Feld(x,y) If Feld(x,y) = "0" Feld(x,y) = "123456789" Else nr(x,y) = Feld(x,y) Next Next solve() draw() AppTitle "READY " WaitKey Function solve() If SolveRegel1() = True solve() If SolveRegel2() = True solve() If SolveRegel3() = True solve() If SolveRegel4() = True solve() If TestSudoku() = False RuntimeError "keine Lösung gefunden" End Function Function TestSudoku() ;Testen, ob gefundene Lösung den Regeln entspricht Local cnt[10] For a=0 To 8 For c=0 To 2 For n=1 To 9:cnt[n]=0:Next For b=0 To 8 If c=0 xx=a:yy=b If c=1 xx=b:yy=a If c=2 xx=(Floor(a/3)*3)+(b Mod 3) : yy=(Floor(a/3)*3)+(b / 3) If Len(Feld(xx,yy)) > 1 Return False ;Testen, ob jede Zahl von 1 - 9 in jeder Zeile,Spalte und Block nur 1 x vorkommt cnt[Feld(xx,yy)]=cnt[Feld(xx,yy)]+1 If cnt[Feld(xx,yy)]<>1 Return False Next Next Next Return True End Function Function SolveRegel1() ; wenn eine Zelle nur eine einzelne Zahl enthält, lösche diese Zahl aus ; allen anderen Zellen dieser Zeile,Spalte und Block. For y=0 To 8 For x=0 To 8 If Len(Feld(x,y)) = 1 For t=0 To 8 For b=0 To 3 If b=0 xx=t : yy=y If b=1 xx=x : yy=t If b=2 xx=(Floor(x/3)*3)+(t Mod 3) : yy=(Floor(y/3)*3)+(t / 3) If Len(Feld(xx,yy)) > 1 s2$=Replace (Feld(xx,yy) , Feld(x,y) , "") If s2 <> Feld(xx,yy) Feld(xx,yy) = s2 found=True EndIf EndIf Next Next EndIf Next Next Return found End Function Dim mark(0,0) Function solveRegel2() ;Wenn sich eine gewisse Anzahl an Zellen in einer Zeile (oder Spalte oder Block) ;die gleiche Anzahl möglicher Ziffern teilen, dann entferne diese Ziffern ;aus allen anderen Zellen dieser Zeile (oder Spalte oder Block). For y=0 To 8 For x=0 To 8 For b=0 To 2 s1$=Feld(x,y) cnt=1 Dim mark(9,9) sb$="" For t=0 To 8 If b=0 xx=t : yy=y If b=1 xx=x : yy=t If b=2 xx=(Floor(x/3)*3)+(t Mod 3) : yy=(Floor(y/3)*3)+(t / 3) If (xx<>x) Or (yy<>y) s2$=Feld(xx,yy) allIn=True For l=1 To Len(s2) m$=Mid$( s2, l , 1) If Instr(s1,m)=0 allIn=False : Exit Next If allIn cnt=cnt+1 mark(xx,yy)=0 sb=sb+s2 Else mark(xx,yy)=1 EndIf EndIf If t=8 And cnt=Len(s1) And cnt>1 allIn=True For l=1 To Len(sb) If Not Instr(s1,Mid$(sb,l,1)) allIn=False:Exit Next If allIn For yy=0 To 8 For xx=0 To 8 If mark(xx,yy)=1 For l=1 To Len(s1) s2$=Replace(Feld(xx,yy),Mid$(s1,l,1),"") If s2 <> "" And s2 <> Feld(xx,yy) Feld(xx,yy)=s2 : found=True Next EndIf Next Next EndIf EndIf Next Next Next Next Return found End Function Function solveRegel3() ;Wenn eine Ziffer nur in einer Zeile (oder Spalte) eines Blocks vorkommt, ;kann in dieser Zeile (Spalte) in keinem anderen Block diese Ziffer vorkommen. ;Also entferne diese Ziffer in der Zeile (Spalte) aus den beiden anderen Blöcken. For x=0 To 8 Step 3 For y=0 To 8 Step 3 For n=1 To 9 For ya=y To y+2 cc=0 For xa=x To x+2 If b=0 If Instr( Feld(xa ,ya ),n ) > 0 yy=ya :cc=cc+1 Next If cc>1 Exit Next c=0 If cc>1 c=1 For xa=x To x+2 For ya=y To y+2 If b=0 If ya<>yy And Instr(Feld(xa,ya),n) > 0 c=0:Exit Next Next EndIf If c=1 For xx=0 To 8 If xx < x Or xx > x+2 s2$=Replace(Feld(xx,yy),n,"") If s2<>"" And s2$<>Feld(xx,yy) Feld(xx,yy)=s2$ : found=True EndIf Next EndIf c=0 For xa=x To x+2 cc=0 For ya=y To y+2 If Instr( Feld(xa ,ya ),n ) > 0 xx=xa :cc=cc+1 Next If cc>1 Exit Next If cc>1 c=1 For ya=y To y+2 For xa=x To x+2 If xa<>xx And Instr(Feld(xa,ya),n) > 0 c=0:Exit Next Next EndIf If c=1 For yy=0 To 8 If yy < y Or yy > y+2 s2$=Replace(Feld(xx,yy),n,"") If s2<>"" And s2$<>Feld(xx,yy) Feld(xx,yy)=s2$ : found=True EndIf Next EndIf Next Next Next Return found End Function Function solveRegel4() ;Wenn eine Ziffer in einer Zeile (oder Spalte) in zwei Blöcken nicht möglich ist, ;dann muss die Ziffer im verbliebenden Block in dieser Zeile stehen. ;Also entferne diese Ziffer aus den beiden anderen Zeilen (oder Spalten) dieses Blocks. For y=0 To 8 Step 3 For x=0 To 8 Step 3 For n=1 To 9 For ya=y To y+2 cc=0 For xa=x To x+2 If Instr(Feld(xa,ya),n)>0 cc=1:Exit Next If cc=1 For xb=0 To 8 If xb<x Or xb>x+2 If Instr(Feld(xb,ya),n)>0 cc=0 : Exit EndIf Next If cc = 1 For xb=x To x+2 For yb=y To y+2 If yb<>ya s1$=Replace(Feld(xb,yb),n,"") If s1<>"" And s1<>Feld(xb,yb) Feld(xb,yb)=s1 : found=True EndIf Next Next EndIf EndIf Next For xa=x To x+2 cc=0 For ya=y To y+2 If Instr(Feld(xa,ya),n)>0 cc=1:Exit Next If cc=1 For yb=0 To 8 If yb<y Or yb>y+2 If Instr(Feld(xa,yb),n)>0 cc=0 : Exit EndIf Next If cc = 1 For yb=y To y+2 For xb=x To x+2 If xb<>xa s1$=Replace(Feld(xb,yb),n,"") If s1<>"" And s1<>Feld(xb,yb) Feld(xb,yb)=s1 : found=True EndIf Next Next EndIf EndIf Next Next Next Next Return found End Function Function draw() Cls For y=0 To 8 For x=0 To 8 Color 100,100,100 Rect x*70+35,y*70+15,71,71,0 If Len(Feld(x,y)) = 1 If nr(x,y)<>0 Color 40,40,70:Rect x*70+38,y*70+18,65,65 Color 255,255,255 Text x*70+70,y*70+50,Feld(x,y) , 1,1 Else Color 255,0,0 Text x*70+70,y*70+72,Feld(x,y) , 1,1 EndIf If x Mod 3 =0 And y Mod 3=0 Color 255,255,255:Rect x*70+34,y*70+14,70*3+1,70*3+1,0 Next Next Flip 0 End Function .dSudoku Data 0,0,1,0,5,7,0,0,2 Data 0,0,0,2,0,0,6,8,0 Data 0,0,9,0,0,0,5,0,0 Data 0,6,8,0,0,9,0,7,5 Data 7,0,0,0,1,0,9,0,0 Data 0,0,2,0,0,3,0,0,0 Data 0,0,0,3,0,0,2,0,0 Data 4,0,0,0,7,0,0,0,8 Data 0,0,0,0,0,8,0,0,0 |
||
da_poller |
Mo, Jul 14, 2008 21:34 Antworten mit Zitat
|
|
|---|---|---|
|
ich habe den löser mal mit 4 mir bekannten sudokus gefüttert(höllisch schwere)
und 4 mal kamen unfertige fehlerhafte sudokus raus.. aber die bedienung des programms ist echt 1A trotz bugs sehr interessant.. |
||
|
Firstdeathmaker |
Mo, Jul 14, 2008 22:52 Antworten mit Zitat
|
|---|---|---|
| Das Program hat einfach den falschen Ansatz. Für das Lösen eines Sudokus musst du einfach ein Branch & Bound Verfahren anwenden, also Rekursiv alle möglichen Kombinationen durchgehen wobei man mit einer Überprüfungsfunktion auf Richtigkeit prüft. | ||
|
www.illusion-games.de
Space War 3 | Space Race | Galaxy on Fire | Razoon Gewinner des BCC #57 User posted image |
||
|
Casiopaya |
Mo, Jul 14, 2008 23:58 Antworten mit Zitat
|
|---|---|---|
|
Korrekt. Ein effizient implementierter Backtracking-Algorythmus schafft (zumindest 9x9-) Sudokus problemlos.
da_poller hat Folgendes geschrieben: ich habe den löser mal mit 4 mir bekannten sudokus gefüttert(höllisch schwere)
Könntest du die mal posten? Würde mich interessieren ob mein Sudoku-Löser (war ne 3h- Übungsaufgabe) den lösen kann. |
||
|
|
Firstdeathmaker |
Di, Jul 15, 2008 0:02 Antworten mit Zitat
|
|---|---|---|
|
Also mein (extrem) unoptimierter Backtracking Algorithmus müsste in der Lage sein ALLE zu lösen:
Code: [AUSKLAPPEN] Graphics 310,310,16,2
ClsColor 255,255,255 Dim sudoku(8,8) Global mx#,my# Global sudoku_selx%,sudoku_sely% Global help% SetFont LoadFont("arial", 20,1) SetBuffer BackBuffer() Repeat mx = MouseX() my = MouseY() Cls sudoku_draw() sudoku_logic() Flip Until KeyHit(1) End Function Sudoku_logic() x = Floor((mx-20)/30.0) y = Floor((my-20)/30.0) If MouseHit(1) ;select field beneath mousepointer If x=>0 And x < 9 If y=>0 And y < 9 sudoku_selx = x sudoku_sely = y EndIf EndIf EndIf If KeyHit(200) And sudoku_sely>0 sudoku_sely = sudoku_sely - 1 ;decrease selected field y - coord If KeyHit(208) And sudoku_sely<9 sudoku_sely = sudoku_sely + 1 ;increase selected field y - coord If KeyHit(203) And sudoku_selx>0 sudoku_selx = sudoku_selx - 1 ;decrease selected field x - coord If KeyHit(205) And sudoku_selx<9 sudoku_selx = sudoku_selx + 1 ;increase selected field x - coord For i=2 To 10 ;write number (1-9) into selected field If KeyHit(i) sudoku(sudoku_selx,sudoku_sely) = i-1 Next If KeyHit(11) Or KeyHit(211) sudoku(sudoku_selx,sudoku_sely) = 0 ;0 or DEL - delete current selected field If KeyHit(57);SPACE solve sudoku Cls Sudoku_draw() Text 10,302,"Work in progress..." Flip 0 Sudoku_solve(0) EndIf If KeyHit(49) sudoku_clear() ;key "n" - empty sudoku paper If KeyHit(59) help=Not help End Function Function Sudoku_solved() If Not Sudoku_valid() Return False For x=0 To 8 For y=0 To 8 If sudoku(x,y) = 0 Return False Next Next Return True End Function Function Sudoku_valid() Local x[9] Local y[9] For bx=0 To 2 For by=0 To 2 For n=0 To 9 x[n]=0 Next For xi=0 To 2 For yi=0 To 2 Local lx = bx*3 + xi Local ly = by*3 + yi If sudoku(lx,ly) If x[sudoku(lx,ly)] Return False Else x[sudoku(lx,ly)]=True EndIf EndIf Next Next Next Next For i=0 To 8 For n=0 To 9 x[n]=0 y[n]=0 Next For i2=0 To 8 If sudoku(i,i2) If x[sudoku(i,i2)] Return False Else x[sudoku(i,i2)]=True EndIf EndIf If sudoku(i2,i) If y[sudoku(i2,i)] Return False Else y[sudoku(i2,i)]=True EndIf EndIf Next Next Return True End Function Function Sudoku_solve(i%) If Not sudoku_valid() Return False x = i Mod 9 y = Lower(i / 9.0) If y=9 Return True If sudoku(x,y) Return Sudoku_solve(i+1) For i2=1 To 9 sudoku(x,y) = i2 If Sudoku_solve(i+1) Return True Next sudoku(x,y) = 0 Return False End Function Function Sudoku_draw() For x%=0 To 8 For y%=0 To 8 Local posx% = 20 + x * 30 Local posy% = 20 + y * 30 If sudoku_selx = x And sudoku_sely = y Color 255,200,100 Rect posx,posy,31,31,1 EndIf Color 0,0,0 Rect posx,posy,31,31,0 If sudoku(x,y) Text posx+15,posy+15,sudoku(x,y),1,1 Next Next Color 0,0,0 For i=0 To 1 Line 111 + 90*i,20,111+90*i,290 Line 20,111 + 90*i,290,111+90*i Next If Sudoku_solved() Text 1,1,"solved sudoku" ElseIf Sudoku_valid() Text 1,1,"valid sudoku" EndIf If help Color 255,255,255 Rect 40,40,230,230 Color 0,0,0 Rect 39,39,232,232,0 Text 155,50,"Help",1,0 Text 50,80,"Arrow Keys - select field" Text 50,100,"'1'-'9' - write number" Text 50,120,"'0' or 'Del' - clear number" Text 50,140,"'space' - solve sudoku" Text 50,160,"'n' clear sudoku field" Text 50,180,"'F1' toggle helpmenue" Text 155,240,"programmed by FDM",1 EndIf End Function Function sudoku_clear() For x%=0 To 8 For y%=0 To 8 sudoku(x,y) = 0 Next Next End Function |
||
|
www.illusion-games.de
Space War 3 | Space Race | Galaxy on Fire | Razoon Gewinner des BCC #57 User posted image |
||
- Zuletzt bearbeitet von Firstdeathmaker am Di, Jul 15, 2008 0:49, insgesamt einmal bearbeitet
|
|
Casiopaya |
Di, Jul 15, 2008 0:29 Antworten mit Zitat
|
|---|---|---|
|
Ich hab mir deinen noch nicht genauer angeschaut, aber es freut mich zu sehen, dass auch andere Leute Spass an Themen haben, die etwas theorethischer, dafür aber umso interessanter sind als nur immer irgendwelche Krach-Bumm-Spiele. Sehr interessant fand ich einige Posts über Wegefindungs-Algorithmen, Solver etc.
Ich fände es toll, wenn diese Community mal in einen Zustand kommen würde, in denen die Contests vielleicht auch mal Namen tragen wie "Schreibt einen Sudoku-Löser, der schnellste gewinnt", oder: "Schreibt ein Pokerprogramm mit Interface, wir lassen die Beiträge gegeneinander spielen und das beste gewinnt" o.Ä. Bevor nun wieder voreilige Posts kommen  Dieses BB-Portal inkl. Community wie sie momentan ist, ist einfach Spitze. Habe ich weder in VB noch in C# irgendwo so erlebt.
|
||
|
|
Firstdeathmaker |
Di, Jul 15, 2008 0:54 Antworten mit Zitat
|
|---|---|---|
|
Nichts gegen hochwertige Krach-Bumm Spiele bitte Nur weil ich z.B. all zu gerne Actionshooter programmiere, heisst das nicht das einfache Algorithmen dahinter stecken!
Und zu den Wettbewerben: Du kannst ja jederzeit gerne einen starten. Wie wäre es einfach mal mit dem Sudoku-Wettbewerb? Allerdings würde ich dazu eher eine Doppelaufgabe stellen: Wer erstellt den besten Sudoku-solver & Creator? Das erstellen von guten Sudokus ist nämlich auch noch mal eine ganze Sache für sich... |
||
|
www.illusion-games.de
Space War 3 | Space Race | Galaxy on Fire | Razoon Gewinner des BCC #57 User posted image |
||
|
Hip Teen |
Di, Jul 15, 2008 8:54 Antworten mit Zitat
|
|---|---|---|
|
Casiopaya, starte sowas einfach mal! Daran hätte ich persönlich mehr Interesse als an den Spielecontests (deren Ergebnisse trotzdem oft sehr schön sind )
@FDM das schwierige ist ja nicht das erstellen von so einem Sudoku, das ist relativ einfach, schwierig wird es den Schwierigkeitsgrad einzustellen bzw. zu bewerten. |
||
| Spruch der Woche: "Ahh, ein neues Gesicht?!" - "Nein, das hab ich schon länger" | ||
|
|
Firstdeathmaker |
Di, Jul 15, 2008 20:28 Antworten mit Zitat
|
|---|---|---|
|
Wer mitmachen möchte:
https://www.blitzforum.de/foru...hp?t=28752 |
||
|
www.illusion-games.de
Space War 3 | Space Race | Galaxy on Fire | Razoon Gewinner des BCC #57 User posted image |
||
Übersicht
BlitzBasic Codearchiv
Powered by phpBB © 2001 - 2006, phpBB Group