Autor Beitrag
Fiete
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starontopic star
Beiträge: 432
Erhaltene Danke: 132

W7
Delphi 6 pro
BeitragVerfasst: Di 10.01.17 11:39 
Moin und frohes neues Jahr,
das Programm löst Alphametik-Aufgaben wie NEPTUN+SATURN+PLUTO=PLANET.
Die Buchstaben müssen so durch Ziffern ersetzt werden, dass eine korrekte Rechnung entsteht.
Gleiche Buchstaben stehen für gleiche Ziffern.
Die Aufgaben stammen teilweise von Truman Collins.
Verschiedene Aufgabensammlungen sind vorhanden, es gibt also genug zu tüfteln.
Es können eigene Sammlungen erstellt und gespeichert werden.
Screen
Algorithmus: In PermListe sind alle 10! Permutationen der 10 Ziffern gespeichert.
Aus den Summanden und der Summe werden die Symbole extrahiert.
ausblenden Delphi-Quelltext
1:
2:
for L:=1 to Length(ErgebnisWort) do
 if pos(ErgebnisWort[L],Symbole)=0 then Symbole:=Symbole+ErgebnisWort[L];

Die ZahlWortListe wird so generiert:
ausblenden Delphi-Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
SetLength(ZahlWortListe,ZWN+1);
for K:=0 to ZWN-1 do
 begin
  Zahlwort:=ZWListe[K];LZW:=Length(Zahlwort);
  ZahlWortListe[K].L:=LZW;
  for L:=1 to LZW do
   ZahlWortListe[K].Ziffern[L]:=pos(Zahlwort[L],Symbole);
  end;

Der Wert der Alphametiken wird so berechnet
ausblenden Delphi-Quelltext
1:
2:
3:
for L:=1 to LZW do
 Zahl:=DEZ*Zahl+Perm[ZahlWortListe[K].Ziffern[L]];
Zahlen[K]:=Zahl;
Viel Spaß beim Testen.
Gruß Fiete

Rev.1:Dank der Unterstützung von user profile iconHorst_H ist die Suche sehr schnell geworden.
rosettacode.org/wiki...utations#alternative
Die lexikografische Erstellung der Permutationen, k aus n wird mittels
der procedure PermKoutOfN(k, n: Integer); berechnet
Einloggen, um Attachments anzusehen!
_________________
Fietes Gesetz: use your brain (THINK)


Zuletzt bearbeitet von Fiete am Mi 18.01.17 12:12, insgesamt 1-mal bearbeitet

Für diesen Beitrag haben gedankt: Frühlingsrolle, Horst_H, Mathematiker, Narses
Horst_H
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starofftopic star
Beiträge: 1544
Erhaltene Danke: 181

WIN7,PuppyLinux
FreePascal,Lazarus,TurboDelphi
BeitragVerfasst: Di 10.01.17 14:00 
Hallo und auch ein frohes Neues,

das funktioniert sogar mit kleinen Einschränkungen mit Lazarus 1.6.2 für Linux 64-Bit ( Umlaute mag der Compiler immer noch nicht und Getasynckey kennt er auch nicht )
Dann ist es sogar erheblich schneller.Der letzte Eintrag bei den 14-stelligen ist dann in 15 Sekunden statt 144 Sekunden fertig.
Was so zusätzliche 8 CPU-Register ausmachen können....

Gruß Horst
Horst_H
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starofftopic star
Beiträge: 1544
Erhaltene Danke: 181

WIN7,PuppyLinux
FreePascal,Lazarus,TurboDelphi
BeitragVerfasst: Fr 13.01.17 12:39 
Hallo,

ich habe das Programm leicht modifiziert um die Berechnung der Zahlen zu beschleunigen.
Die Zifffern zeigen jetzt direkt auf die Position in der Permutation.Damit ist 32-Bit Version für Lazarus unter wine auch bei 18 Sekunden, für die längsten Zahlen.
Die Änderungen müsste auch mit Delphi funktionieren.
Die Trackbar Position wird jetzt alle 16384 Berechnungen angepasst, was 0,5% Äderung entspricht, weil es doch erheblich Zeit kostet und immer noch flüssig aussieht.

Gruß Horst

Einfach die entsprechende Teile im Original ersetzen:
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:
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:
type
  TPermDat = byte;
  tpPermDat = ^TPermDat;
  TPerm = array[1..DEZ] of TPermDat;

  TZiffern = record
    L: integer;
    Ziffern: array[1..NMax] of tpPermDat
  end;
...
procedure TAlphametic.AlphaLoesenClick(Sender: TObject);
const
  Leer = '                ';
var
  LZW, LEW, ZWN, K, I, idx, AN: NativeInt;
  ZWListe, Loesung: array of string;
  ZahlWortListe: array of TZiffern;
  Zahlen: array of int64;
  Zahl32 : LongInt;
  Zahl, Summe, Ergebnis: int64;
  ErgebnisWort, Zahlwort, Zeile, Symbole: string;
  Perm: TPerm;
  OK, Vorhanden, Alle: boolean;
begin
  Ausgabe.Clear;
  Ausgabe.SetFocus;
  ZWN := 0;
  AN := 0;
  SetLength(Loesung, AN + 1);
  Loesung[0] := '###';
  for K := 0 to SummandenEingabe.Lines.Count - 1 do
    if SummandenEingabe.Lines[K] <> '' then
    begin
      Inc(ZWN);
      SetLength(ZWListe, ZWN);
      ZWListe[ZWN - 1] := SummandenEingabe.Lines[K];
    end;
  if ZWN = 0 then
  begin
    MessageDlg('Es gibt KEINE Summanden!', mtError, [mbRetry], 0);
    exit;
  end;
  Symbole := '';
  for K := 0 to ZWN - 1 do
  begin
    Zahlwort := ZWListe[K];
    LZW := Length(Zahlwort);
    for idx := 1 to LZW do
      if pos(Zahlwort[idx], Symbole) = 0 then
        Symbole := Symbole + Zahlwort[idx];
  end;
  ErgebnisWort := EditS.Lines[0];
  if ErgebnisWort = '' then
  begin
    MessageDlg('Michael Ende läßt grüßen, die unendliche Geschichte(das NICHTS)!',
      mtError, [mbRetry], 0);
    exit;
  end;
  for idx := 1 to Length(ErgebnisWort) do
    if pos(ErgebnisWort[idx], Symbole) = 0 then
      Symbole := Symbole + ErgebnisWort[idx];
  if Length(Symbole) > DEZ then
  begin
    MessageDlg('Zuviele Symbole!', mtError, [mbRetry], 0);
    exit;
  end;
  SummandenEingabe.Alignment := taRightJustify;
  EditS.Alignment := taRightJustify;
  SetLength(Zahlen, ZWN);
  // Berechnungsliste wird erstellt
  SetLength(ZahlWortListe, ZWN + 1);
  for K := 0 to ZWN - 1 do
  begin
    Zahlwort := ZWListe[K];
    LZW := Length(Zahlwort);
    with ZahlWortListe[K] do
    begin
      L := LZW;
      for idx := 1 to LZW do
        Ziffern[idx] := @Perm[pos(Zahlwort[idx], Symbole)];
    end;
  end;
  LEW := Length(ErgebnisWort);
  with ZahlWortListe[ZWN] do
  begin
    L := LEW;
    for idx := 1 to LEW do
      Ziffern[idx] := @Perm[pos(ErgebnisWort[idx], Symbole)];
  end;
  if LoesungErste.Checked then
    Alle := False
  else
    Alle := True;
  Screen.Cursor := crHourGlass;
  TrackBar.Max := NFak;
  // Zahlwort in Zahl wandeln
  for I := 1 to NFak do
  begin
    Summe := 0;
    Perm := PermListe[I];
    OK := True;
    for K := 0 to ZWN - 1 do
    begin
      Zahl32 := 0;
      with ZahlWortListe[K] do
      begin
        LZW := L;
        IF L > 9 then
        Begin
          for idx := 1 to 9 do
            Zahl32 := DEZ * Zahl32 + Ziffern[idx]^;
          Zahl := Zahl32;
          for idx := 10 to L do
            Zahl := DEZ * Zahl + Ziffern[idx]^;
        end
        else
        Begin
          for idx := 1 to L do
            Zahl32 := DEZ * Zahl32 + Ziffern[idx]^;
          Zahl := Zahl32;
        end;
      end;

      inc(summe,Zahl);
      Zahlen[K] := Zahl;
      if Length(IntToStr(Zahl)) <> LZW then
      begin
        OK := False;
        Break;
      end// falsche Länge wegen der Null
    end;
    if OK then
    begin
      Ergebnis := 0;
      with ZahlWortListe[ZWN] do
      begin
        for idx := 1 to LEW do
          Ergebnis := DEZ * Ergebnis + Ziffern[idx]^;
      end;
      OK := OK and (LEW = Length(IntToStr(Ergebnis))); // falsche Länge wegen der Null
      if OK AND (Summe = Ergebnis) then
      begin
        Vorhanden := False;
        Zeile := '';
        for idx := 1 to Length(Symbole) do
          Zeile := Zeile + IntToStr(Perm[idx]);
        for idx := 0 to AN do
          if Loesung[idx] = Zeile then
            Vorhanden := True;
        if not Vorhanden then
        begin
          Inc(AN);
          SetLength(Loesung, AN + 1);
          Loesung[AN] := Zeile;
          idx := Length(IntToStr(Ergebnis));
          for K := 0 to ZWN - 1 do
          begin
            LZW := Length(IntToStr(Zahlen[K]));
            Ausgabe.Lines.Add(copy(Leer, 1, idx - LZW) + IntToStr(Zahlen[K]));
          end;
          Ausgabe.Lines.Add('_______________');
          Ausgabe.Lines.Add(IntToStr(Ergebnis));
          Ausgabe.Lines.Add(#13 + #10 + Symbole + #13 + #10 + Zeile);
          Ausgabe.Lines.Add(IntToStr(AN) + '-te Lösung');
          Ausgabe.Lines.Add('');
          Application.ProcessMessages;
          if not Alle then
            break;
        end;
      end;
    end;
    if I mod 16384 = 0 then
    begin
      Trackbar.Position := I;
      Application.ProcessMessages;
      //       if GetAsyncKeyState(VK_Escape)<0 then if MessageDlg('Suche abbrechen?',mtConfirmation,[mbYes,mbNo],0)=mrYes then break
    end;
  end;
  Screen.Cursor := crDefault;
  if AN = 1 then
    ShowMessage('Fertig mit der Arbeit!' + #13 + 'Es gibt genau eine Lösung.')
  else if AN = 0 then
    ShowMessage('Fertig mit der Suche!' + #13 + 'Es gibt KEINE Lösung.')
  else
    ShowMessage('Fertig mit der Arbeit!' + #13 + 'Es gibt ' +
      IntToStr(AN) + ' Lösungen.');
end;

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

W7
Delphi 6 pro
BeitragVerfasst: Mi 18.01.17 12:15 
Moin,
die neue modifizierte Version ist hochgeladen.
user profile iconHorst_H hat sehr gute Arbeit geleistet.
Gruß Fiete

_________________
Fietes Gesetz: use your brain (THINK)
Frühlingsrolle
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starhalf ontopic star
Beiträge: 955
Erhaltene Danke: 126

[Win NT] 5.1 x86 6.1 x64
[Delphi] 7 PE, 2006, 10.1 Starter, Lazarus - [C#] VS Exp 2012 - [Android API 15] VS Com 2015, Eclipse, AIDE
BeitragVerfasst: Gestern um 01:38 
Deine Projekte sind immer wieder ein Hit, so wie dieses hier. Wenn man mit den Themen vertraut ist, lassen sich die Quelltexte auch ganz gut nachvollziehen. Ich wünschte mir, du würdest mehr OOP anwenden, damit sich jenes noch viel leichter lesen lässt. Die Anwendungen erfüllen durchaus ihren Zweck, aber wenn mich schon die Neugier packt, dann möchte ich deine Vorgehensweise zu jenen Thema auch besser nachvollziehen können.

_________________
„Nicht für das Leben, sondern für die Schule lernen wir.“ „Kürze die lange Rede, damit sie nicht verdächtig wirke!“
(Lucius Annaeus Seneca : 1 - 65 n. Chr)