Rekursiver Algorithmus zur Kombinatorik optimierbar? (solved) (Allgemeines zu Perl)

[thread]18652[/thread]

Rekursiver Algorithmus zur Kombinatorik optimierbar? [solved]

Tags: Kombinatorik Multiset Algorithmus Similar Threads

Readers: 17

Articles: hide open all | hide show old branches

+12 replies
ariser

2013-10-05 21:31
User since
2012-08-17
44 articles
BenutzerIn
Hi,

ich benötige sowas ähnliches, wie ein multiset aus einer gegebenen Menge.
Leider bin ich kein Mathematiker, deswegen kenne ich schon den Namen des Problems nicht
Eine Menge M mit k Elementen soll mit n verschiedenen Elementen besetzt werden. Dabei muss in der Menge k jedes Element von n mindestens einmal vorkommen, woraus folgt, dass n<=k sein muss.
Es sollen nun für geg. k u. n alle möglichen M berechnet werden. Dabei spielt die Reihenfolge in M keine Rolle, also alle Permutationen einer M werden vernachlässigt.
Oder anders formuliert, die Mengen M sollen nach ihren Elementen sortiert sein.

Ich erklärs noch mal praktisch. Der Disponent (oder wie man das nennt) am Münchner Hauptbahnhof muss jeden Tag einen Autoreisezug mit 10 Wagen zusammenstellen, der nach Rom fährt. Er kann Personenwagen, KFZ-träger, LKW-Träger einstellen, und Güterwagen. Nach der Lok kommen diese Wagen aus Sicherheitsgründen in genau der Reihenfolge. Weil nie alle Buchungen sicher sind, muss er mindestens einen Wagen jeder Art einstellen, in Summe aber 10 erreichen. Also z.B. PPKKKKLLGG. Oder PKLGGGGGGG.

Ich hätte gerne einen Algorithmus, der die Zahl k und die n verschiedenen Elemente, z.b. Strings als Array bekommt und dann alle Kombinationen als AoA zurückgibt. Ok, das AoA wird noch nicht erzeugt, aber das ist ja kein Problem.

Der Witz ist, ich habs schon geschrieben, rekursiv, funktioniert auch. Hier:
Code: (dl )

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

my @typeset = ('P', 'K', 'L', 'G'); my $length = 10; my @lchain = (); strangemultiset($length, \@typeset, \@lchain); exit 0; sub strangemultiset { my $len=$_[0]; my @types=@{$_[1]}; my @chain=@{$_[2]}; my $ltype=shift(@types); my $var=$len - scalar(@chain) - scalar(@types); for(my $iter=1; $iter<=$var; ++$iter) { push(@chain, $ltype); if (scalar(@types) == 0) { if (scalar(@chain) == $len) { # we have a valid set, print it. print join('.', @chain), "\n"; } } else { strangemultiset($len, \@types, \@chain); } } }
Hier fehlt noch die Ausgabe in ein AoA, aber das kann man sich dazudenken.

Fällt jemand spontan ein, wie man das nicht-rekursiv machen kann ohne sich die Finger zu brechen? Ich mein, rekursiver Code ist fast immer unperformant, man macht den Stack voll usw.
- +2 replies
- Raubtier
  
  2013-10-06 00:17
  User since
  2012-05-04
  1081 articles
  BenutzerIn
  Dazu drei Kommentare:
  
  1. von deiner Beschreibung mit den Mengen ist nicht klar geworden, was du tun willst. Wohl aber hat das Beispiel klar gemacht, was zu tun ist.
  
  2. Rekursive Algorithmen sind nicht immer schlecht. Bei Endrekursion muss der Stack auch nicht überlaufen (hängt von den Optimierungen eines Compilers ab)
  
  3. Zur Lösung musst du dir erst einmal überlegen, dass du eh alle 4 Elemente einmal brauchst. Es bleiben also nur noch 6 Wagen übrig, die frei vergeben werden können.
  
  Die Anzahl der Möglichkeiten ist binomial(anzahl_wagentypen + anzahl_verbleibende_wagen - 1, anzahl_verbleibende_wagen) = binomial(4+6-1, 6) = 9!/(6! * 3!) = 84
  
  Stichwort ist vielleicht "Ziehen mit Zurücklegen".
  
  Edit: ich sehe gerade, dass du gar nicht die Anzahl haben wolltest, sondern wirklich alle Ergebnisse. Das würde ich immer rekursiv lösen. Vielleicht so:
  
  Code (perl): (dl )
  
  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
  
  my @typeset = qw(P K L G); my $length = 10; strangemultiset($length, \@typeset, 0, ''); sub strangemultiset { my ($len, $set, $start, $string) = @_; if ($len == 0) { print "$string\n"; return; } my $max = $len - @$set + $start + 1; my $min = $start == @$set - 1 ? $max : 1; for my $currentLen ($min..$max) { strangemultiset($len-$currentLen, $set, $start + 1, $string . ($set->[$start] x $currentLen)); } }
  
  Last edited: 2013-10-06 01:21:03 +0200 (CEST)
  - ariser
    
    2013-10-06 19:04
    
    User since
    2012-08-17
    44 articles
    BenutzerIn
    
    Danke für die Tips.
    
    Punkt 3 ist logisch, fiel mir aber bislang nicht auf. Je nachdem, wie man die Rekursion gestaltet, kann man wohl etwas Code sparen.
    
    Dein Code ist generell etwas kürzer und reduziert die Parameterübergabe by value auch etwas. Ich kopiere ja immer beide Arrays, was Zeit kostet. Bei Dir sinds nur strings. Bin gerade dabei mal alle Vorschläge zu vergleichen.
- +9 replies
- topeg
  
  2013-10-06 00:37
  User since
  2006-07-10
  2611 articles
  BenutzerIn
  Jede rekursive Lösung lässt sich als Iterative darstellen.
  
  Ich würde es wohl so machen:
  
  Code (perl): (dl )
  
  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
  
  #!/usr/bin/perl use strict; use warnings; my @typeset = qw(P K L G); my $length = 10; strangemultiset(\@typeset,$length); sub strangemultiset { my ($typeset,$length)=@_; my @lst=map{1}@$typeset; while(@lst <= @$typeset) { my $len=0; $len+=$_ for(@lst); if($len >= $length) { my @out; push(@out, ($typeset[$_]) x $lst[$_]) for(0..$#$typeset); print join('.',@out)."\n"; } $lst[0]++; for my $p (0..$#lst) { my $left = 0; $left += $_ for(@lst); if($left > $length) { $lst[$p] = 1; $lst[$p+1] ++ ; } } } }
  
  Wobei fraglich ist, ob die Lösung schneller ist als die Rekursive. Speicher sparender dürfte sie wohl sein.
  - +8 replies
  - ariser
    
    2013-10-06 19:40
    
    User since
    2012-08-17
    44 articles
    BenutzerIn
    
    Hi,
    
    vielen Dank für die Lösung. Ich hab jetzt mal alle drei Varianten verglichen und ich bin vom Ergebnis ziemlich überrascht. Ich hab dazu „100 Wagons“ genommen, das Print inklusive der Verkettung auskommentiert und stattdessen eine einfache Zuweisung rein, damit sich der Interpreter nicht um die Schleifen drückt.
    
    Ergebnis (mit „time“ gemessen):
    Meine Variante: 17 s
    topegs Variante: 43 s
    Raubtiers Variante: 1 s
    
    Find ich irre. Beweist das, dass rekursive Algorithmen schnell sind? Und wenn ja, warum eigentlich?
    Eins sieht man IMHO deutlich: Die Verwendung von Strings statt Arrays bringt einen heftigen Geschwindigkeitsvorteil. Der ist so groß, dass es vermutlich besser ist, die Strings zu erzeugen, und hinterher bei Bedarf zu zerschneiden. Bis jetzt ziemlich lehrreich das Ganze.
    
    Was ich nicht gemacht hab, ist den Speicherverbrauch zu messen. Ich weiß gar nicht wie.
    - +2 replies
    - Raubtier
      
      2013-10-06 20:21
      
      User since
      2012-05-04
      1081 articles
      BenutzerIn
      
      Zur Rekursion fällt mir noch ein: http://xkcd.com/1270/
      
      Und Speicherverbrauch: daran ist überhaupt nichts kritisch. Mein Script macht so viele Rekursionen wie es unterschiedliche Waggontypen gibt - und der String ist so lang wie der Zug. Da muss man noch nicht mal an Speicherverbrauch denken.
      Last edited: 2013-10-06 20:34:53 +0200 (CEST)
      - GwenDragon
        
        2013-10-06 20:35
        
        User since
        2005-01-17
        14835 articles
        Admin1
        
        Ist der Comic so zu verstehen: Dick enlargment? ;) ROFL Jugendfrei musste jetzt sein :)
        die Drachin Gwen
        
        Meine Perl-Artikel · perldev – verschiedene Perl-Versionen unter Windows starten
    - +5 replies
    - topeg
      
      2013-10-06 21:01
      
      User since
      2006-07-10
      2611 articles
      BenutzerIn
      
      2013-10-06T17:40:32 ariser
      Beweist das, dass rekursive Algorithmen schnell sind? Und wenn ja, warum eigentlich?
      
      Perl ist eine interpretierte Sprache. Jedes Kommando das du schreibst repräsentiert eine ohne mehrere Funktionen in Perl. Da passieren viele Überprüfungen um alle Kontexte, in dem ein Befehl ausgeführt werden kann, korrekt zu behandeln. Gleiches geschieht bei Zugriffen auf Variablen. Grundsätzlich wird viel gemacht was in diesem speziellen Fall nicht nötig ist. Das macht Perl 50-100 mal langsamer als compilierter Code.
      Bei Funktionsaufrufen passiert fast alles im Kern von von perl, das ist hoch optimiert und läuft im nativen Maschinencode ab. Darum ist in dem Fall eine Rekursion günstiger. Werden aber große Datenmengen kopiert fällt das ins Gewicht, wie deine Variante zeigt.
      Das ist aber nur auf Interpreter bezogen. Bei compiliertem Code ist eine iterative Lösung meist schneller, da viele Prüfungen und kopieren von Werten weg fallen können, die bei Funktionsaufrufen gemacht werden.
      - ariser
        
        2013-10-07 20:18
        
        User since
        2012-08-17
        44 articles
        BenutzerIn
        
        Klingt logisch. Ich fand den Thread ziemlich aufschlussreich.
        Da bei meiner Aufgabe, die übrigens nix mit Zügen zu tun hat, die „Länge des Zuges“ meist noch etwas kleiner sein wird, hab ich momentan wenig Probleme mit egal welcher Lösung, aber ich werde genau schauen, ob ich nicht beim nächsten solchen Problem gleich auf eine entsprechende Optimierung hinarbeite. Auch einige meiner früheren Code-Verbrechen werd ich mir u.U. nochmal anschauen. :)
        
        Was mich noch juckt, ist, bei Raubtiers Lösung den String mit Split in ein AoA zu schreiben und dann die Laufzeiten mit den anderen zu vergleichen.
        
        Aber erstmal Danke für die Analysen!
      - +3 replies
      - Raubtier
        
        2013-10-07 20:37
        
        User since
        2012-05-04
        1081 articles
        BenutzerIn
        
        War es nicht so, dass gerade Funktionsaufrufe in Perl einen recht großen Overhead haben? Meine sowas gelesen zu haben.
        
        Diese Unterschiede machen aber nicht so viel aus, dass die ein Algorithmus 1s und einer 40s braucht. Da würde ich die Ineffizienz anderswo suchen.
        
        +2 replies
        
        topeg
        
        2013-10-07 21:44
        
        User since
        2006-07-10
        2611 articles
        BenutzerIn
        
        Ja Funktionsaufrufe sind nicht günstig, da ein ganz neuer Gültigkeitsbereich erzeugt wird, mit allen definierten und speziellen Variablen, deren Inhalte kopiert werden müssen. Aber das ist immer noch günstiger als das kopieren von Variablen mit "der Hand", da eine ganze Reihe von Prüfungen nicht gemacht werden.
        
        Zudem hat mein Code vier Schleifen, von denen bis zu drei in einander gestaffelt sind, jede erzeugt einen eigenen Gültigkeitsbereich, und Variablen werden erzeugt/kopiert. Über eine Rekursion kann man sich einige Schleifen sparen, da der übergeordnete Gültigkeitsbereich direkt im Core erhalten und verwaltet wird. Vieles was man ansonsten im eigenen Code implementieren müsste (z.B über einen eigenen Stack) macht perl für einen so effizient wie möglich.
        Man muss es halt abwägen/ausprobieren, wann das kopieren bei Funktionen das Verwalten im Core überwiegt.
        
        Mein Code ist auch nicht der Effizienteste den man in Perl schreiben kann. Dieses Beispiel wäre in Assembler/C sehr schnell, da er sich mit wenig und effizientem Code implementieren lässt.
        Es handelt sich um einen n stelligen Zähler (hier n=4), der in einem "m-wertigen" Zahlenraum arbeitet (hier m=10-n). Wenn die Summe aller Stellen 10 ist erfolgt eine Ausgabe. Alle Durchläufe sind erreicht wenn der Zähler überläuft.
        Das erzeugt in Perl viele unnötige und "teure" Durchläufe, die alle Zeit kosten, da jedes mal der Gültigkeitsbereich der Schleifen neu erstellt wird. Man könnte sich wahrscheinlich noch zwei Schleifen sparen, wenn man $len und $left nicht über eine Schleife jedes mal neu erzeugt, sondern bei allen Operationen auf @lst passend addiert oder subtrahiert. Dennoch wäre man dann immer noch bei zwei Schleifen. gegenüber eines Funktionsaufrufs, der einem auch noch die Verwaltung der Gültigkeitsbereiche abnimmt.
        Last edited: 2013-10-07 21:47:58 +0200 (CEST)
        
        Raubtier
        
        2013-10-07 22:48
        
        User since
        2012-05-04
        1081 articles
        BenutzerIn
        
        (entfernt, weil nicht richtig)
        Last edited: 2013-10-07 23:02:03 +0200 (CEST)

View all threads created 2013-10-05 21:31.