Autor |
Beitrag |
Fiete
Beiträge: 611
Erhaltene Danke: 347
W7
Delphi 6 pro
|
Verfasst: 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.
Algorithmus: In PermListe sind alle 10! Permutationen der 10 Ziffern gespeichert.
Aus den Summanden und der Summe werden die Symbole extrahiert.
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:
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
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 Horst_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: Horst_H, Mathematiker, Narses
|
|
Horst_H
Beiträge: 1653
Erhaltene Danke: 243
WIN10,PuppyLinux
FreePascal,Lazarus
|
Verfasst: 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
Beiträge: 1653
Erhaltene Danke: 243
WIN10,PuppyLinux
FreePascal,Lazarus
|
Verfasst: 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:
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); 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; 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; 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))); 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; 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
Beiträge: 611
Erhaltene Danke: 347
W7
Delphi 6 pro
|
Verfasst: Mi 18.01.17 13:15
Moin,
die neue modifizierte Version ist hochgeladen.
Horst_H hat sehr gute Arbeit geleistet.
Gruß Fiete
_________________ Fietes Gesetz: use your brain (THINK)
|
|
Frühlingsrolle
Ehemaliges Mitglied
Erhaltene Danke: 1
|
Verfasst: Sa 21.01.17 02:38
- Nachträglich durch die Entwickler-Ecke gelöscht -
|
|
Fiete
Beiträge: 611
Erhaltene Danke: 347
W7
Delphi 6 pro
|
Verfasst: 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.
Fragen zu den benutzten Algorithmen beantworte ich gern.
Gruß an den Wissensdurstigen
Fiete
_________________ Fietes Gesetz: use your brain (THINK)
|
|
Frühlingsrolle
Ehemaliges Mitglied
Erhaltene Danke: 1
|
Verfasst: Mo 23.01.17 15:48
- Nachträglich durch die Entwickler-Ecke gelöscht -
|
|
Horst_H
Beiträge: 1653
Erhaltene Danke: 243
WIN10,PuppyLinux
FreePascal,Lazarus
|
Verfasst: 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
|
|
Daniel_DT
Beiträge: 16
|
Verfasst: Di 25.04.17 10:35
Alphametik-Aufgaben sind leider bisschen zu hoch für mich. ich weiß.. shame on me
|
|
jand
Hält's aus hier
Beiträge: 1
|
Verfasst: Sa 04.12.21 20:31
Ist das Thema noch aktuell? Hab da ein ganz anderes Ergebnis.
Konkretisierender Nachtrag:
Gleichung: neptun + saturn + pluto = planet
Ergebnis: 104951 + 289561 + 43597 = 438109
Ergebnis: 159431 + 704381 + 96342 = 960154
Ergebnis: 196721 + 387201 + 64275 = 648197 <-- stimmt überein
Ergebnis: 216482 + 374892 + 65840 = 657214
Ergebnis: 357063 + 290683 + 71604 = 719350
Insgesamt 5 Lösungen
|
|
Horst_H
Beiträge: 1653
Erhaltene Danke: 243
WIN10,PuppyLinux
FreePascal,Lazarus
|
Verfasst: Fr 21.01.22 21:01
Hallo,
ich habe das Programm gestartet.
Es wird im Normalfall nur die erste gefundene Lösung angezeigt.
Das kann man ändern, wenn man Erste/Alle Lösung auswählt.
Dann sind es auch 5 Lösungen
Gruß Horst
Einloggen, um Attachments anzusehen!
|
|
|