Nonogramm/Griddler - Solver

Horst_H · Verfasst: Sa 20.05.06 09:24

Hallo,

wo ist Dein Ansatz nicht genau Brute force?
Du versuchst alle Kombinationen (mindestens einer Zeile,Spalte) vorab zu bestimmen und zu verifizieren.
Beim Backtracking wird eine Kombination nach der anderen erzeugt, was einfach speichersparend ist und frueher bei falschen Loesungen abbricht.
Ich hab doch oben mal geschrieben das die Anzahl der Anordnungen pro Zeile,Spalte = (Anzahl der beweglichen Leerstellen)! ist.
Aber poste doch mal Deine Loesung, und es waere schoen, wenn man sich zumindest auf das Fileformat oben einigen koennte :-)

Gruss Horst

delfiphan · Beiträge: 2684 Erhaltene Danke: 32

Beim Spiel kann man doch ganz sicher ohne grosses Probieren viele Fälle direkt aus der Logik ableiten. Es gibt bestimmt viele Fälle die man einfach so mal algorithmisch relativ einfach lösen kann. Einfaches Beispiel: Wenn die Zeilenlänge 20 ist und man hat eine einzelne "12" auf der Seite, so kann man doch daraus direkt schliessen, dass die mittleren 4 schwarz eingefärbt sein müssen. Oder wenn die Zahlen links plus die Anzahl der Zahlen minus eins genau die Zeilenlänge gibt kann man die Zeile grad einfärben und die entsprechenden Zahlen streichen.
Ich kenne das Spiel jetzt auch nur grad vom Forum hier aber solche "Tricks" müsste es eigentlich viele geben, sonst könnte man es ja nicht von Kopf lösen. Es wäre ja irgendwie langweilig wenn es viele Punkte gäbe wo man mit der Logik einfach nicht mehr weiter kommt und man einfach so raten muss. Es gibt sicher so Fälle, die Enden dann aber hoffentlich bald in einer Inkonsistenz... Aber wer weiss, vielleicht ist ja genau das, was ein schweres Nonogramm "schwer" (oder besser gesagt mühsam) macht.
Ein Programm, welches zusätzlich für jeden Schritt noch eine Begründung ausgibt ist doch viel interessanter als eines, welches das Spiel einfach so durch pures Backtracking oder probieren löst. Da könnte man ja gleich einfach alle Möglichkeiten durchprobieren. Das finde ich aber weniger spannend.

PS: Es geht glaube ich auch nicht nur ums Einfüllen. Man kann einem Feld auch ein "sicher weiss" zuordnen.

LLCoolDave · Beiträge: 212 Win XP Delphi 2005

Horst: Nein, mein Ansatz stellt für mich kein Brute Forcing dar. Brute Force wäre z.B. das erstellen und prüfen aller 2^(zeilenzahl*spaltenzahl) möglichen Nonogramme, und dann prüfen, ob es zu dem gegebenen Spielfeld passt. Auch die intelligentere Variante, nur Nonogramme zu erstellen, die die richtige Anzahl an schwarzen Feldern haben, ist immer noch pures rumprobieren und raten. Auch das Backtracking ist für mich ein gewisses Bruteforce, wenn auch etwas zielgerichteter. Trotzdem wird dort erst mal etwas probiert, und wenn es auf einen Wiederspruch stößt, kann da ja wohl nicht das richtige gewesen sein.

Mein Ansatz hingegen ahmt die menschliche Vorgehensweise nach. Zunächst einmal sind für eine einzelne Zeile/Spalte alle möglichkeiten möglich. Jedoch gibt es bei bestimmten Zeilen/Spalten, wie von delphifan schon erwähnt, Felder, die mit Sicherheit eingefärbt sind. Das ist der Angriffspunkt, mit dem ein Mensch an ein solches Rätsel herangeht, und genau das selbe macht mein Programm auch. Wenn man alle möglichkiten einer solchen Zeile/Spalte miteinander vergleicht, stellt man fest, das eben in allen Möglichkeiten bestimmte Felder immer eingefärbt sind. Da es für diese dann keine andere Möglichkeit mehr gibt, werden sie eingefärbt. Nach eben diesem Verfahren geht mein Programm vor. Es probiert also nicht willkürlich herum, sondern geht strikt nach dem Ausschlussverfahren logisch vor. Das es dabei nicht unbedingt effizient arbeitet, ist mir klar, aber ich würde das sicher nicht als Brute Force bezeichnen.

Nunja, hier mal mein Code, wer Verbesserungsvorschläge hat (die Grundidee des Algorithmus würde ich gerne beibehalten, mein Ziel ist es wie schon erwähnt nicht, einen effizienten Solver zu schaffen, sondern einen, der die menschliche Logik nachahmt) soll sie ruhig nennen, schneller unf effektiver darf das Ganze schon laufen, vielleicht kriegen wir das ja noch so getunet, das auch ein 50x50 Nonogramm mit meinen bescheidenen 512MB Ram zu schaffen sind, auch wenn es ne Stunde oder so dauert.

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:

type TSArray = Array of string;
type TIArray = Array of integer;
type TFeld = Array of Array of char;
type TSpielfeld = record
     Spalten: Array of string;
     Zeilen: Array of string;
     Sppos: Array of TSArray;
     Zlpos: Array of TSArray;
     Feld,FeldBackup: TFeld;
     spaltenzahl,zeilenzahl: integer;
     end;

//Gibt die am weitesten rechts liegende Startposition des Blocks m[0] bei der Blockliste m und der Feldbreite n zurück (BSP: GetMaxPosition(6,(1,2)) = 2)
function GetMaxPosition(n: integer; m:TIArray):integer;  
var i,j: integer;
begin
j:= -1;
for i:=0 to High(m) do j:=j+m[i]+1;
result := n - j;
end;

//Dafür gibts zwar auch in Delphi eine function, aber mir ist der Name nicht eingefallen ;)
function MakeString(n: integer; c:char):string;
var i: integer;
begin
result := '';
for i:=1 to n do result := result+c;
end;

//Fügt den string s an das Ende des TSArray ouput
procedure AddString(s: string; var output: TSarray);
begin
setlength(output,length(output)+1);
output[high(output)] := s;
end;


//Gibt einen TSArray zurück, der s+jeden String aus input enthält
procedure AddStrings(s: string; input: TSarray; var output: TSarray);
var i: integer;
begin
for i:=0 to high(input) do
  begin
  Addstring(s+input[i], output);
  end;
end;

//Gibt für die Blöcke m und der Feldbreite n alle möglichen Anordnungen zurück
function positions(n: integer; m: TIArray):TSArray;
var i: integer;
    tempsarray: TSArray;
begin
setlength(tempsarray,0);
for i:=0 to GetMaxPosition(n,m) do
  begin
    if length(m) > 1 then
    Addstrings(MakeString(i,'1')+MakeString(m[0],'2')+'1',positions(n-i-m[0]-1,copy(m,1,length(m))),tempsarray)
    else Addstring(MakeString(i,'1')+MakeString(m[0],'2')+MakeString(n-i-m[0],'1'),tempsarray);
  end;
result := tempsarray;
end;

//Macht ein Backup eines TFeld (zum Vergleich, ob sich etwas geändert hat)
procedure Backup(from: TFeld; var backup: TFeld);
var i,j: integer;
begin
for i:=0 to high(from) do
  for j:=0 to high(from[0]) do
    backup[i,j] := from[i,j];
end;

//Vergleicht zwei TFeld
function CompareFields(field1,field2: TFeld): boolean;
var i,j: integer;
begin
result := false;
for i:=0 to high(field1) do
  for j:=0 to high(field1[0]) do
    if not(field1[i,j] = field2[i,j]) then exit;
result := true;
end;

//Bisher hab ich noch keine Brauchbare Eingabe, läuft derzeit über Strings, daher diese Umwandlungsfunktion
function stringtoTIArray(s: string):TIArray;
var tempiarray: TIArray;
begin
  setlength(tempiarray,0);
  while pos(',',s) > 0 do
  begin
    setlength(tempiarray,length(tempiarray)+1);
    tempiarray[high(tempiarray)] := strtoint(copy(s,1,pos(',',s)-1));
    delete(s,1,pos(',',s));
  end;
  Result := tempiarray;
end;

//Initialisiert das Spielfeld
procedure Initialize(var Spielfeld: TSpielfeld);
var i,j: integer;
begin
with Spielfeld do
begin
  spaltenzahl := strtoint(Form1.Edit1.text);
  zeilenzahl := strtoint(Form1.Edit2.text);
  Setlength(Spalten,spaltenzahl);
  Setlength(Zeilen,zeilenzahl);
  Setlength(Sppos,spaltenzahl);
  Setlength(Zlpos,zeilenzahl);
  Setlength(Feld,spaltenzahl,zeilenzahl);
  Setlength(FeldBackup,spaltenzahl,zeilenzahl);
  for i:=0 to zeilenzahl-1 do for j:=0 to spaltenzahl-1 do
    begin
    Feld[j,i] := '0'; FeldBackup[j,i] := '1';
    end;
  for i:=0 to spaltenzahl-1 do
    begin
    Form1.Caption := 'Initialisieren: Spalte '+inttostr(i+1);
    Application.Processmessages;
    if abbruch then exit;
    Spalten[i] := Form1.Memo1.lines[i];
    Sppos[i] := positions(zeilenzahl,stringtoTIArray(Spalten[i]));
    end;
  for i:=0 to zeilenzahl-1 do
    begin
    Form1.Caption := 'Initialisieren: Zeile '+inttostr(i+1);
    Application.Processmessages;
    if abbruch then exit;
    Zeilen[i] := Form1.Memo1.lines[i+spaltenzahl];
    Zlpos[i] := positions(spaltenzahl,stringtoTIArray(Zeilen[i]));
    end;
end;
end;

//Entfernt ein Element aus einem Array, gibt sicher auch schon ne procedure dafür
procedure removearray(i: integer; var SArray: TSArray);
var j: integer;
begin
for j:=i to high(SArray)-1 do
  SArray[j] := SArray[j+1];
Setlength(Sarray,length(SArray)-1);
end;

//Entfernt alle Möglichkeiten aus dem TSArray, die nicht zu der derzeitigen Spielsituation (s) kompatibel sind
procedure RemoveSolutions(s: string; var SArray: TSArray);
var i,j: integer;
begin
for i:=1 to length(s) do
  if not (s[i] = '0') then
  for j:=high(SArray) downto 0 do
    if not (SArray[j][i] = s[i]) then removearray(j, SArray);
end;

//Erstellt basierend auf der derzeitigen Situation (s) und dem TSArray aller möglichkeiten einen String, der Felder enthält, die sich als logisch zwingend erwiesen haben
function CreateEntryString(s: string; SArray: TSArray): string;
var i,j: integer;
    b: boolean;
    tempstring: string;
begin
tempstring := '';
for i:=1 to length(s) do
  if s[i] = '0' then
  begin
  b := true;
  for j:=1 to high(SArray) do
    if not (SArray[j][i] = SArray[j-1][i]) then
    begin
      b := false;
      break;
    end;
  if (b) and (length(SArray)>0) then tempstring := tempstring + SArray[0][i] else tempstring := tempstring + '0';
  end else tempstring := tempstring + '0';
result := tempstring;
end;

//Eigentliche Lösungsschleife
procedure Solveloop(var spielfeld: TSpielfeld);
var counter,i,j: integer;
    tempstring: string;
begin
counter := 0;
with Spielfeld do
begin
  while CompareFields(Feld,FeldBackup) = false do
  begin
    inc(counter);
    Form1.Caption := 'Durchgang '+InttoStr(counter);
    Application.ProcessMessages;
    Backup(Feld,FeldBackup);
    for i:=0 to high(Spalten) do
      begin
      tempstring := '';
      for j:=0 to high(Feld[i]) do
        tempstring := tempstring + Feld[i,j];
      RemoveSolutions(tempstring,Sppos[i]);
      tempstring := CreateEntryString(tempstring,Sppos[i]);
      for j:=1 to length(tempstring) do
        if not(tempstring[j] = '0') then
          Feld[i,j-1] := tempstring[j];
      end;
    for i:=0 to high(Zeilen) do
      begin
      tempstring := '';
      for j:=0 to high(Feld) do
        tempstring := tempstring + Feld[j,i];
      RemoveSolutions(tempstring,Zlpos[i]);
      tempstring := CreateEntryString(tempstring,Zlpos[i]);
      for j:=1 to length(tempstring) do
        if not(tempstring[j] = '0') then
          Feld[j-1,i] := tempstring[j];
      end;
  end;
end;
end;

Ist etwas unübersichtlich

Kleine Anmerkung: '0' = unbekannt '1' = Schwarz '2' = weiß

Horst_H · Verfasst: Mo 22.05.06 20:23

Hallo,

vielleicht leuchtet Dir mal ein, warum ich Min und MaxStartPos fuer jeden Block haben wollte.
wenn Max-Min < Laenge => sicher zu markierende Stellen.
Du haettest ruhig mal ein Beispielnonogramm und den kompletten Code (*.pas;*.dpr;*.dfm) anhaengen koennen, damit man es auch mal sieht.
Ich habe es bei mir etwas veraendert, indem ich einfach noch eine Liste Zeiger auf die einzelnen Spalten,Zeilen, die ich nach den niedrigsten Anzahl an freien Stellen sortiere(egal ob Spalte oder Zeile).
Dann trage ich erst alle sicheren Stellen in das Feld[Spalte,Zeile] ein

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:

tFeldPos = record
             belegt: boolean;
             ZeilenBlock,
             SpaltenBlock: integer;//-1 , falls nicht eindeutig
           end;

Dann trage ich also erst komplett alle fixen Werte ein.
Und dann bin ich noch nicht weiter ;-)

.
Jetzt muesste ich aus fixen Werten fuer ZeileBlk,SpalteBlk auf die SpalteBlk, ZeileBlk schliessen.
Also ich finde hinter einem fixen SpaltenBlk eine Spalte weiter etwas durch einen ZeileBlk gefixtes, was bedeutet das fuer den Block dieser Spalte->MinStartpos erhoeht sich um eins.Falls davor sinkt MaxStartPos um 1 usw.
Habe ich den Letzen oder ersten Block gibt es ja zusaetzliche Einschraenkungen.
Eine in der ersten Zeile belegete,gefixte Stelle heisst autmatisch, dass dort der erste Spaltenblock beginnt, den man dann komplett eintragen und aus der Liste der freien Bloecke dieser Spalte entfernt(ans Ende setzt und einen Zaehler verringert) kann.
Dann muss man sich vielleicht noch die Zusammenhaenge, aufeinanderfolgender Bloecke in einer Reihe mal zu Gemuete fuehren, dass man z.B einen gefixten Punkt genau einem quer-Block zu ordnen kann , sodass sofort alle Vorgaenger und Nachfolger in Ihrer Position weiter eingeschraenkt werden.
Wenn MinStartPos= MaxStartpos ist ja alles in Butter.
Das macht noch Arbeit.

Gruss Horst

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme