1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:

X1111
1...o
1..o.
1.o..
1o...
Oder
X1111
1o...
1..o.
1.o..
1...0
etc...                    

1:
2:
3:
4:
5:
6:
7:

  :X??????????
34:000___0000
34:000__0000_
34:000_0000__
34:_000__0000
34:_000_0000_
34:__000_0000                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:

//soviele Durchläufe wie es Zeichenpositionen je Zeile gibt
for i:= 0 to 10 //Anzahl der Positionen
begin
 //
 for j:= 0 to AnzZuBelegendeZeichen
 begin
  if j<10 then 
  begin
    zeile[i]:='#';
  end
  else
  begin //bei Überlauf von vorne beginnen
    zeile[j-i]:='#';  
  end;
 end;
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:

Procedure CreateCombinations (S, I,K,Row, P)
Begin
  For J := K to Board.Width - 1 do
    If IsBlock(Board[Row, J], S[i]) Then // An Pos (Row,J) kann ein Block der Länge S[i] sein
      If I = Length(S) Then // Der letzte Block wurde gefunden
        AddToCombinations (P + [J])// Der Lösungsvektor P + [J] ist eine Möglichkeit
     else
       CreateCombinations (S,I+1, J+S[j]+1, P+[J])
End;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:

tRule = record 
          rules    :array[1..maxrule] of integer;
          startpt  :array[1..maxrule] of integer;
          rulesCnt : integer;  //Wieviele sind es wirklich
          fixedlength: integer;//fest eingefuegt 
          fixedrule [1..maxrule] of boolean;//fest eingefuegt 
       end;

tSpalte = array[1..weidth] of tRule;
tZeile  = array[1..height] of tRule;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:

Procedure FindRowCombinations (B : TPosArray; aRow, aBlockIndex, aStartPos : Integer; P : TPosArray);
Var
  J, iThisBlockWidth : Integer;

Begin
  iThisBlockWidth := B[aBlockIndex]; // so einen Block wollen wir plazieren
  For j:=aStartPos To Board.Width - iThisBlockWidth Do
     If Board.CanPutABlockAtPos (J,iThisblockWidth) Then Begin
       P[aBlockIndex] := J;
       If aBlockIndex = Length (B) Then Begin // Der letzte Block wurde plaziert
         Solutions.Add (P);  // Also ist P eine Möglichkeit und kommt zum Lösungsvektor
       End
       Else // Ansonsten versuchen wir, den nächsten Block zu plazieren
         FindRowCombinations (B, aRow, aBlockIndex + 1, J + iThisblockWidth + 1, P);
     End
End;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:

Schleife: Wiederhole das so lange, bis sich nichts mehr verändert hat:

  Schleife:
  Gehe alle Zeilen/Spalten durch, wenn die Anzahl der eingefärbten Felder 
  der Summe der Elemente des darauf bezogenen Arrays entspricht, 
  setze alle ungewissen Felder auf Null.

  Schleife:
  Gehe alle Zeilen/Spalten durch, wenn die Anzahl der ungewissen Felder 
  der Summe der Elemente des darauf bezogenen Arrays minus der bereits eingefärbten entspricht, 
  setze alle ungewissen Felder auf Eins.

  Schleife:
  Suche nach fertigen Abschnitten im Feld, und setze das Feld hinter dem Abschnitt auf Null.                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:

maxBlkcnt :integer = const
tBlock = record
            BlkLength   : integer;
            StartPos,       //als Laufvariable von min bis max
            MinStartPos,
            maxStartPos :integer;
            Fixed       : Boolean; //oder MinStartpos=MaxStartPos machen
          end;
tRowCol = record    
             Blocks    : array[1..maxBlkcnt] of tBlock;   
             BlockCnt  : integer;
             Blockfixed: array[1..Blkcnt] of boolean;
          end;   

tSpalte = array[1..weidth] of tRowCol;   
tZeile  = array[1..height] of tRowCol;                    

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;                    

1:
2:
3:
4:
5:

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