Autor Beitrag
Fiete
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starontopic star
Beiträge: 477
Erhaltene Danke: 178

W7
Delphi 6 pro
BeitragVerfasst: Do 03.03.16 11:53 
Moin,
eine Superdame(Amazone) vereinigt die Dame und den Springer in einer Figur.
Wie beim N-Damen-Problem werden N Amazonen so auf einem NxN-Schachbrett verteilt,
dass sie sich gegenseitig nicht schlagen können.
Wer nur die erste Stellung haben möchte kann dies auswählen,
ebenso können alle Stellungen gespeichert und in echte Stellungen aussortiert werden.
Amazonen
Bei großen Werten für die Anzahl der Damen gibt es die Möglichkeit
die Suche mit <ESC> abzubrechen.
An der Geschwindigkeit der Suchroutine läßt sich bestimmt noch einiges
verbessern, da hoffe ich auf user profile iconHorst_H :wink:
Viel Spaß beim Testen
Gruß Fiete

Edit1: eine verbesserte Version liegt vor, nach Ideen von user profile iconHorst_H
statt 3,78s jetzt 0,91s
eine Auswertung ist hier oprisch.net/SuperQueens/SuperQueens.html
Einloggen, um Attachments anzusehen!
_________________
Fietes Gesetz: use your brain (THINK)


Zuletzt bearbeitet von Fiete am So 19.06.16 13:36, insgesamt 2-mal bearbeitet

Für diesen Beitrag haben gedankt: Mathematiker
Horst_H
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starofftopic star
Beiträge: 1618
Erhaltene Danke: 224

WIN7,PuppyLinux
FreePascal,Lazarus,TurboDelphi
BeitragVerfasst: So 05.06.16 09:24 
Hallo,

hab ich ja noch gar nicht gesehen....
Ich habe es mir jetzt nicht in die Tiefe gehend angesehen.Bei mir ( i3 4330 3,5 Ghz ) braucht 13-Damen 5.5 Sekunden unter wine.Vielleicht ist Memo wieder extra langsam...
Das n-Damen Problem sehr schnell zu lösen ist:
rosettacode.org/wiki..._problem#Alternative bei 13 dauert es 0.1 Sekunden für 73712 Lösungen.
Mein Gedanke. n-Damen lösen und dann nur noch auf Verstoß gegen Super-Dame testen. Das müsste doch was bringen.

Gruß Horst
Fiete Threadstarter
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starontopic star
Beiträge: 477
Erhaltene Danke: 178

W7
Delphi 6 pro
BeitragVerfasst: Fr 10.06.16 12:51 
Moin Horst,
werde Deine Idee mal aufgreifen und testen.
Kann aber etwas dauern.(EM und Beale - Chiffre) :wink:
Gruß Fiete

_________________
Fietes Gesetz: use your brain (THINK)
Fiete Threadstarter
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starontopic star
Beiträge: 477
Erhaltene Danke: 178

W7
Delphi 6 pro
BeitragVerfasst: Mo 13.06.16 13:51 
Moin Horst,
habe Deine Idee mal getestet, Ergebnis im Anhang.
Die alte Setz-Prozedur habe ich modifiziert(Anweisungen auskommentiert):
Hier die neue
ausblenden volle Höhe 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:
procedure TAmazone.Setz(S:Integer);
  var Z,K:Integer;
      F:TBrett;
      ZNeu,SNeu:Integer;
  begin
   for Z:=1 to BG do
    if Brett[Z,S]=0 then
     begin
      F:=Brett; // Brett zwischenspeichern
      // Felder waagerecht sperren
      for K:=S+1 to BG do Brett[Z,K]:=Gesperrt;
      // Diagonalen sperren
      for K:=1 to 2 do
       begin
        ZNeu:=Z+RY[K];SNeu:=S+RX[K];
        while Erlaubt(ZNeu,SNeu) do
         begin
          Brett[ZNeu,SNeu]:=Gesperrt;
          SNeu:=SNeu+RX[K];ZNeu:=ZNeu+RY[K];
         end
       end;
      // Springerzugmöglichkeit
      for K:=1 to 8 do
       begin
        ZNeu:=Z+WA[K];SNeu:=S+SE[K];
        if Erlaubt(ZNeu,SNeu) then
        Brett[ZNeu,SNeu]:=Gesperrt;
       end;
      Brett[Z,S]:=SpringerDame;
   (*   Application.ProcessMessages;
      if GetAsyncKeyState(VK_Escape)<0 then
       begin
        Abbruch:=True;
        exit;
       end;    *)

      if S<BG then Setz(S+1)
      else
       begin
       // if Abbruch then exit;
        inc(N);
        if Zeigen.Checked then
         begin
          Ausgabe(N,Brett,0);
          if not Vorhanden(Brett) then
           begin
            inc(SN);Ausgabe(SN,Brett,1);
       //     LabelSN.Caption:=IntToStr(SN);LabelSN.Repaint;
           end;
         end;
       // LabelN.Caption:=IntToStr(N);LabelN.Repaint;
       end;
      Brett:=F; // Zug rückgängig machen
      if (N>0and STerste.Checked then exit
     end
  end;

Für N=16 erhalte ich 202.900 Lösungen in 8,11s
Die N-Damenvariante bei der jede Lösung auf Springerverträglichkeit getestet wird ist zu langsam(82,45s),
von 14.772.512 Lösungen sind nur noch 202.900 zulässig!
Gruß Fiete
Einloggen, um Attachments anzusehen!
_________________
Fietes Gesetz: use your brain (THINK)
Horst_H
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starofftopic star
Beiträge: 1618
Erhaltene Danke: 224

WIN7,PuppyLinux
FreePascal,Lazarus,TurboDelphi
BeitragVerfasst: Di 14.06.16 15:56 
Hallo,

ich bekomme Deine Zeiten mit Deinem Programm auch bei verändertem TAmazone.Setz(S:Integer) nicht hin. ( 550 Sekunden für 16 ???? mit Lazarus 1.6 für win32 )
Ich habe mein Programm mal geändert.
Wie bei n-Damen wird für jede Zeile eine freie Spalte gewählt und diesmal aber auch getestet, ob in Zeile davor eine Spalte im Abstand 2 oder zwei Zeilen davor eine Amazone in Abstand von einer Spalte steht.
Es ist etwas getrickst.nmax = 17, aber nur bis 16 gerechnet sonst ist das Ergebnis falsch! 198??? statt 202900.
Aber das in 1.12 Sekunden ist ja auch nicht schlecht ;-)
ausblenden volle Höhe 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:
program Amazone;
{$IFDEF FPC}
  {$MODE DELPHI}
  {$OPTIMIZATION ON}
{$ELSE}
  {$Apptype console}
{$ENDIF}

uses
  sysutils;// TDatetime
const
  nmax = 17;
type
{$IFNDEF FPC}
  NativeInt = longInt;
{$ENDIF}
  //ala Nikolaus Wirth  A-1  = H - 8
  //diagonal left  (A1) to rigth (H8)
  tLR_diagonale = array[-nmax-1..nmax-1of char;
  //diagonal right (A8) to left (H1)
  tRL_diagonale = array[0..2*nmax-2of char;
  //up to Col are the used Cols, after that the unused
  //added 2 fields in front to remove check if row>=1 or row>=2 for knight move
  tFreeCol = array[-2..nmax] of NativeInt;
var
  LR_diagonale:tLR_diagonale;
  RL_diagonale:tRL_diagonale;
  //Using pChar, cause it is implicit an array
  //It is always set to
  //@LR_diagonale[row] ,@RL_diagonale[row]
  pLR,pRL : pChar;
  FreeCol : tFreeCol;
  i,
  n : nativeInt;
  gblCount : nativeUInt;
  T0,T1 : TdateTime;

procedure Solution;
var
  i : NativeInt;
begin
// Take's a lot of time under DOS/Win32
  If gblCount AND $FFF = 0 then
    write(gblCount:10,#8#8#8#8#8#8#8#8#8#8);
  // IF n< 9 then
  IF n < 0 then
   begin
     For i := 1 to n do
       write(FreeCol[i]:4);
     writeln;
   end;
end;

procedure SetAmazone(Row:nativeInt);
var
  i,Col : nativeInt;
begin
IF row <= n then
  begin
  For i := row to n do
    begin
    Col := FreeCol[i];
    //check diagonals are not occupied
    If (ORD(pLR[-Col]) AND ORD(pRL[Col]))<>0 then
      //check knight-move one and two rows before actual row
      IF (Abs(FreeCol[row-1]-col)<>2AND (Abs(FreeCol[row-2]-col)<>1then
      Begin
        //a "free" position is found
        //mark it
        pRL[ Col]:=#0;      //RL_Diagonale[ Row +Col] := 0;
        pLR[-Col]:=#0;      //LR_Diagonale[ Row -Col] := 0;
        //swap FreeRow[Row<->i]
        FreeCol[i] := FreeCol[Row];
        FreeCol[Row] := Col;
        //next row
        inc(pRL);
        inc(pLR);
        // check next row
          SetAmazone(Row+1);
        //Undo
        dec(pLR);
        dec(pRL);
        FreeCol[Row] := FreeCol[i];
        FreeCol[i] := Col;
        pRL[ Col]:=#1;
        pLR[-Col]:=#1;
        end;
      end;
  end
else
  begin
  //solution ist found
  inc(gblCount);
  //Solution
  end;
end;

begin
  FreeCol[-2] := High(FreeCol[0]);
  FreeCol[-1] := High(FreeCol[0]);
  FreeCol[0] := High(FreeCol[0]);
  For i := 1 to nmax do
    FreeCol[i] := i;
  FreeCol[nmax+1] := High(FreeCol[0]);
  //diagonals filled with True = #1 , something <>0
  fillchar(LR_Diagonale[low(LR_Diagonale)],sizeof(tLR_Diagonale),#1);
  fillchar(RL_Diagonale[low(RL_Diagonale)],sizeof(tRL_Diagonale),#1);
  For n := 1 to nMax-1 do
    begin
    t0 := time;
    pLR:=@LR_Diagonale[0];
    pRL:=@RL_Diagonale[0];
    gblCount := 0;
    SetAmazone(1);
    t1:= time;
    WriteLn(n:6,gblCount:12,FormatDateTime(' NN:SS.ZZZ',T1-t0),' secs');
    end;
  WriteLn('Fertig');
end.
{    9           0 00:00.000 secs
    10           4 00:00.001 secs
    11          44 00:00.000 secs
    12         156 00:00.001 secs
    13        1876 00:00.005 secs
    14        5180 00:00.028 secs
    15       32516 00:00.168 secs
    16      202900 00:01.116 secs}


Gruß Horst
Edit:
Leicht modifizierter Test auf Rösselsprung, indem ich 2 Spalten davor zusätzlich eingeführt habe.

Für diesen Beitrag haben gedankt: Fiete
Fiete Threadstarter
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starontopic star
Beiträge: 477
Erhaltene Danke: 178

W7
Delphi 6 pro
BeitragVerfasst: Sa 18.06.16 16:43 
Moin Horst,
ein Lob an den Tüftler :!:
Die Abfrage vor dem Setzen einzubauen war super anstatt erst eine Stellung zu erzeugen und dann zu testen :idea:
Das falsche Ergebnis 198??? statt 202900 lässt sich vielleicht ermitteln, setze mal die Compilerschalter {$R+,Q+}
Gruß Fiete

_________________
Fietes Gesetz: use your brain (THINK)