Autor Beitrag
Fiete
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starontopic star
Beiträge: 436
Erhaltene Danke: 138

W7
Delphi 6 pro
BeitragVerfasst: Di 10.01.17 12: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 13: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: 1555
Erhaltene Danke: 191

WIN7,PuppyLinux
FreePascal,Lazarus,TurboDelphi
BeitragVerfasst: Di 10.01.17 15: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: 1555
Erhaltene Danke: 191

WIN7,PuppyLinux
FreePascal,Lazarus,TurboDelphi
BeitragVerfasst: Fr 13.01.17 13: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: 436
Erhaltene Danke: 138

W7
Delphi 6 pro
BeitragVerfasst: Mi 18.01.17 13: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: 1171
Erhaltene Danke: 183

[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 - [C++] Builder 10.1
BeitragVerfasst: Sa 21.01.17 02: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)
Fiete Threadstarter
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starontopic star
Beiträge: 436
Erhaltene Danke: 138

W7
Delphi 6 pro
BeitragVerfasst: Mo 23.01.17 14:43 
Moin Frühlingsrolle,
meine ersten Programmiererfahrungen machte ich 1969 mit Algol 60 und PL/1.
Die Denkweise in OOP ist für mich alten Tüftler ungewohnt,
mein Beharrungsvermögen ist proportional zum Alter, also weiter prozedural oder funktional. :wink:
Fragen zu den benutzten Algorithmen beantworte ich gern.
Gruß an den Wissensdurstigen
Fiete

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

[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 - [C++] Builder 10.1
BeitragVerfasst: Mo 23.01.17 15:48 
Guten Tag Fiete,

alte Gewohnheiten wird man schwer los, das verstehe ich. Dann bleibt es dabei, und wenn etwas missverständlich sein sollte, werde ich dich darauf aufmerksam machen. Vielen Dank für die zahlreichen Tüftelein. :wave:

_________________
„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)
Horst_H
ontopic starontopic starontopic starontopic starontopic starontopic starontopic starofftopic star
Beiträge: 1555
Erhaltene Danke: 191

WIN7,PuppyLinux
FreePascal,Lazarus,TurboDelphi
BeitragVerfasst: Mo 23.01.17 16:03 
Hallo,

es muss ja nicht OOP sein.Es reichte, wenn man viele kleine Prozeduren und Funktionen nutzen und dort zudem ein paar mehr Kommentare reinpacken würde, um die Vorgehensweise verständlicher zu machen.Aber das lerne ich wohl auch nicht mehr ;-)

Gruß Horst