RDW #2 - Rätsel der Woche Nr. 2 (Seite 8) (Allgemeines zu Perl)

[thread]6406[/thread]

RDW #2 - Rätsel der Woche Nr. 2 (Seite 8)

Tags: RDW Ähnliche Threads

Leser: 1

Crian

2004-07-19 12:18

User since
2003-08-04
5866 Artikel
ModeratorIn

[quote=ptk,16.07.2004, 21:36]Ich hab's der Übersicht halber sortiert, aber unsortiert sollte OK sein.[/quote]
genau

[quote=Taulmarill,17.07.2004, 20:02]allerdings bin ich mal gespannt zu sehen, ob einem der anfänger (wie man das auch immer definieren will) eine gute lösung gelingt.[/quote]
Da bin ich aber auch mal gespannt, bisher erscheint mir meine Lösung als die uneleganteste :-/

[quote=pq,18.07.2004, 17:32]ich bin gespannt, was crian morgen dazu sagt, dass wir einfach einen
golf-wettbewerb draus gemacht haben =)[/quote]
Kein Problem, das geht einfach in zwei Kategorien ein, außerdem bekommt ihr alle Punktabzüge, wenn ihr die Funktion nicht geschrieben habt ;-)

Nein ich denke man sollte hier nicht streng herum "regeln", das ganze ist dazu gedacht zum Perl-Programmieren anzuregen, wie die Aufgaben letztlich gelöst werden ist mir egal.

Ich werde versuchen, zuminsdest immer eine nicht-golf-Lösung zu erstellen, damit Anfänger ggf. wenigstens eine Lösung haben, die sie verstehen können. Aber davon gibts diesmal wohl genug :D

Ich bin über die Resonanz begeistert ... ich hoffe ich komme diesmal auch zu einer Auswertung :-)

Das wird aber frühestens morgen Abend geschehen können, da wir immernoch Gäste haben bis morgen früh.\n\n

s--Pevna-;s.([a-z]).chr((ord($1)-84)%26+97).gee; s^([A-Z])^chr((ord($1)-52)%26+65)^gee;print;

use strict; use warnings; Link zu meiner Perlseite

Crian

2004-07-19 12:36

User since
2003-08-04
5866 Artikel
ModeratorIn

Wenn ich es richtig sehe, sind die drei Tage jetzt gerade um. Ich werde deshalb die Lösungen hier posten und später auch auf die Wiki-Seite stellen (wenn ich sie dann mal hochgeladen habe, wird heute bestimmt nichts, siehe oben).

Die Lösungen poste ich nach Datum sortiert nach dem alter meiner Dateien, nicht böse sein, wenn das nicht mit der Reihenfolge des Abschickens übereinstimmt.

Betterworld:

Code: (dl )

#!/usr/bin/perl
# Dieses Skript gibt die Potenzmenge der Liste seiner Parameter aus.
# Loesung von betterworld / perl-community.de

require 5.8.1; # Wegen (??{})
use strict;
use warnings;
use locale; # für [:print:]
use re 'eval';


my %hash;

sub pushit{
  my @ar = grep {defined and length } map {eval '$'.$_} 1..@ARGV;
  my $cute_list = join ",", @ar;

  # An alle Tester: Gibt das bei Euch auch einen Segfault, wenn man diese
  # Zeile durch $cute_list =~ s/\n//g ersetzt?
  # Und wenn ich beides nehme, passieren noch seltsamere Sachen...
  $cute_list =~ y/\n//d;

  $hash{$cute_list} = undef if length $cute_list;
  return qr/^.^/; # Das sollte nie matchen --> Backtracing
}

my $A = (join "\n", @ARGV)."\n";
my $re = join '(?:^.*\n)*', map {'(^.*\n)?'} 1..@ARGV;

# Hier passiert die eigentliche Arbeit
$A =~ m/$re(??{pushit()})/m;

print "{";
if ("\370" =~ /[[:print:]]/) {
  print "\370";
} else {
  print "{}";
}

# Hier benutze ich ";" statt ",", damit man durch Zaehlen der Semikola in der
# Ausgabe leicht ueberpruefen kann, dass es 2**n Elemente sind.
print "; {$_}" for sort keys %hash;

print "}\n";

Ronnie:

Code: (dl )

#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper;

my @bulk = (1, 2, 3);
my @mask = map {[split '', $_]} glob "{0,1}" x @bulk;
my @resultset;

foreach my $row (@mask) {
  push @resultset, [grep {$_!=0} map {$bulk[$_] * $row->[$_]} (0..$#bulk)];
}

print Dumper \@resultset;
exit;

Renee:

Code: (dl )

#! /usr/bin/perl
use strict;
use warnings;

use Data::Dumper;


my @array = qw(1 2 3 4 5);

my $potenz = P(\@array);

print Dumper($potenz);



sub P{
  my ($arrayref) = @_;
  my $potenzmenge = [];
  my $base = [[]];
  my $bool = 1;
  my $length = 0;
  while($bool){
    push(@$potenzmenge,@$base);
    $base = calc_elems($base,$arrayref,$length);
    $length++;
    $bool = 0 if($length > scalar(@$arrayref))
  }

  return $potenzmenge;
}


sub calc_elems{
  my ($base,$arrayref,$length) = @_;
  my @array = @{$arrayref};
  my @new_elems = ();

  foreach my $base_elem(@$base){
    foreach my $index($length..(scalar(@array) - 1)){
      my @tmp_elem = @{$base_elem};
      last if($tmp_elem[-1] && ($tmp_elem[-1] >= ($array[-1])) &&
$length > 0);
      next if($tmp_elem[-1] && (($tmp_elem[-1] == $array[$index]) ||
$tmp_elem[-1] > $array[$index]));
      push(@tmp_elem,$array[$index]);
      push(@new_elems,[@tmp_elem]);
    }
  }

  return \@new_elems;
}

ptk:

Code: (dl )

#!/usr/bin/perl

use strict;

# Eingabe
my @array = 1..3;

my %res;
oneless@array;

# Formatierung der Ausgabe
# Key als Array umschreiben
my @res;
whilemy$k = each %res {
    push @res, split /,/, $k;
}
# Ergebnisarray schoener sortieren
@res = sort {
    my $r = @$a = @$b;
    if $r == 0 {
        join,, @$a cmp join,, @$b;
    } else {
        $r;
    }
} @res;
require DataDumper;
print DataDumper-new\<@res,'res'-Indent0-Dump, \<n;

sub oneless {
    my @array = @_;
    $res{ join,,@array } = 1;
    return if !@array;
    for my $i 0 .. $#array {
        onelessmap { $array$_ } 0 .. $i-1, $i+1 .. $#array;
    }
}

s--Pevna-;s.([a-z]).chr((ord($1)-84)%26+97).gee; s^([A-Z])^chr((ord($1)-52)%26+65)^gee;print;

use strict; use warnings; Link zu meiner Perlseite

Crian

2004-07-19 12:39

User since
2003-08-04
5866 Artikel
ModeratorIn

Crian:

Code: (dl )

#!/usr/bin/perl
use strict;
use warnings;

use Data::Dumper;


my $A = [ 'a', 'b', 'c', 'd', 'e' ];
my $P = P($A);

print "A = {", join(', ', @$A), "}\n";
print "P(A) = {\n";
for my $p (@$P) {
    print "         {", join(', ', @$p), "},\n";
}
print "       }\n";


sub P {
    my ($A) = @_;
    my $P   = [];

    for my $anzahl_elemente (0 .. scalar @$A) {
        push @$P, teilmengen($A, $anzahl_elemente);
    }

    return $P;
}


sub teilmengen {
    my ($A, $n) = @_;

    my @T = ();
    my $N = scalar @$A;

    if (0 == $n) {
        push @T, [];
    }
    else {
        # $n Elemente aus $N Elementen auswaehlen:
        my @Mengen; # Menge mit Nummermengen
        for my $element (1..$n) {
            my @M;

            # Moegliche Nummern fuer Element $element berechnen:
            for my $nummer ($element..$N-($n-$element)) {
                push @M, $nummer-1;
            }

            # Bei einelementigen Mengen Mengen mit nur diesem Element
            # erzeugen:
            unless (@Mengen) {
                push @Mengen, [ $_ ] for @M
            }

            # Anderenfalls Jede bisherige Nummernmenge aus @Mengen
            # vervielfachen und an jede Kopie eine der neuen
            # moeglichen Nummern anhaengen:
            else {
                my @TM = @Mengen;
                @Mengen = ();
                for my $tm (@TM) {
                    for my $m (@M) {
                        unless (grep { $_ >= $m } @$tm) {
                            push @Mengen, [ @$tm, $m ];
                        }
                    }
                }
            }
        }

        # Umsetzen der Nummern auf die Elemente der Menge:
        for my $menge (@Mengen) {
            push @T, [ map { $_ = $A->[$_] } @$menge ];
        }
    }

    return @T;
}

Taulmarill:

Code: (dl )

#!/usr/local/bin/perl

use strict;
use warnings;
use Data::Dumper;

my @maengeA = qw/1 2 3/;

print Dumper funcP(@maengeA);

sub funcP {
    return () unless @_;
    return ( [ $_[0] ] ) unless @_ >= 1;

    map {
        my $first = shift @_;
        [$first], map { [ $first, @$_ ] } funcP(@_)
    } @_;
}

Murphy:

Code: (dl )

#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper;

sub potset {
    my @set = @{shift(@_)};

    if (@set == 0) {
    return [[]];
    }
    else {
    my @ps = @{potset([@set[1..$#set]])};

    return [(map { my @l = @$_; push @l, $set[0]; [@l]; } @ps), @ps];
    }
}

print Dumper(potset(\@ARGV));

Code: (dl )

(define (potset s)
      (if (eqv? s '())
       '(())
       (let ((ls (potset (cdr s))))
        (append ls (map (lambda (l) (cons (car s) l)) ls)))))

Esskar:

Code: (dl )

#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper;

print Dumper P(\@ARGV);

sub P {
   my($m,$e,$p)=(@_,[],[]);
   !@{$m}and push@{$p},$e or
   P(@_=@{$m}and pop and[@_],[@{$e}],$p)and
   P(@_=@{$m}and pop and[@_],[sort@{$e},$m->[-1]],$p);
   [sort{@{$a}<=>@{$b}}@{$p}]
}

DS:

Code: (dl )

#!perl

use strict;
use warnings;
use Data::Dumper;

print Dumper [sort { @$a <=> @$b } &p(@ARGV ? @ARGV : (0,'',undef))];

sub p { my @p = ([]); push @p, map [@$_,$_[0]], @p and shift while @_; @p }
#sub p { @_ || return []; my $e = shift; p(@_),map [@$_,$e], p(@_) }

Code: (dl )

### Eingabe-Menge ausgeben
	print "Eingabe-Menge: {"
	set S0, ""
	set I4, 0
	set I5, P5
_print_em:
	inc I4
	eq I4, I5, _print_em_ende
	set S5, P5[I4]
	print S0
	set S0, ","
	print S5
	bsr _print_em
_print_em_ende:
	print "}\n"

### Programm initialisieren
	new P1, .PerlArray	# Potenzmenge
	new P2, .PerlArray	# wird initislisiert mit der "leeren Menge" als einziges Element
	set P1[0], P2

### Potenzmenge berechnen
	set I4, 0		# aktueller Index für P5
	set I5, P5		# Elemente in P5
_p:	# while
	inc I4
	eq I4, I5, _p_ende
	set P0, P5[I4]		# aktuelles Element der Eingabe-Menge

	set I0, 0		# aktueller Index für P1
	set I1, P1		# Elemente in P1
_p_map:	# map
	set P2, P1[I0]
	clone P3, P2		# aktuelle Teilmenge aus P1 kopieren,
	push P3, P0		# um aktuelles Element der Eingabe-Menge erweitern
	push P1, P3		# und wiederum an P1 anhängen

	inc I0
	ne I0, I1, _p_map
	bsr _p
_p_ende:
	
### Potenzmenge ausgeben
	print "Potenzmenge:   {"
	set S0, ""
	set I0, 0
	set I1, P1
_print_pm:
	print S0
	set S0, ","
	set P8, P1[I0]

	print "{"
	set S1, ""
	set I7, 0
	set I8, P8
	unless I8, _print_pm_tm_ende
_print_pm_tm:
	set S8, P8[I7]
	print S1
	set S1, ","
	print S8
	inc I7
	ne I7, I8, _print_pm_tm
_print_pm_tm_ende:
	print "}"

	inc I0
	ne I0, I1, _print_pm
	print "}\n"

### Programm beenden
	end

s--Pevna-;s.([a-z]).chr((ord($1)-84)%26+97).gee; s^([A-Z])^chr((ord($1)-52)%26+65)^gee;print;

use strict; use warnings; Link zu meiner Perlseite

Crian

2004-07-19 12:41

User since
2003-08-04
5866 Artikel
ModeratorIn

pq:

Code: (dl )

#!/usr/bin/perl
# RDW 2
# 18.07.2004
# author: pq
# usage: skript.pl 1 2 3 4 ...
package main;
use strict;
use warnings;
my @a = @ARGV;
my @res =  p(@a);
print "Die Potenzmenge von (@a):\n";

for (sort {
		 @$a <=> @$b
	} @res) {
	print "(@$_)\n";
}

sub p {
	my @m = @_;
	unless (@m) {
		# die Potenzmenge der leeren Menge ist die leere Menge
		return [];
	}
	else {
		my $el = shift @m;
		# um die Potenzmenge einer Menge M herauszufinden,
		# nimmt man sich ein Element e und bildet die Potenzmenge PR
		# der Restmenge R
		# jede Untermenge U in PR verdoppelt man und fügt
		# dem Duplikat das Element e hinzu
		my @p = map {([@$_, $el], $_)} p(@m);
		return @p;
	}
}

Code: (dl )

1
2
3

#!/usr/bin/perl
@_=[];for$e(@ARGV){@_=map{[@$_,$e],$_}@_}print"(@$_)
"for@_

s--Pevna-;s.([a-z]).chr((ord($1)-84)%26+97).gee; s^([A-Z])^chr((ord($1)-52)%26+65)^gee;print;

use strict; use warnings; Link zu meiner Perlseite

Crian

2004-07-19 12:48

User since
2003-08-04
5866 Artikel
ModeratorIn

Und hier noch eine zweite Variante von mir, wo alles in einer Funktion P zusammengefasst ist:

Code: (dl )

#!/usr/bin/perl
# Autor: Crian
# RDW 02 - Berechnung der Potenzmenge einer Menge
# Variante 2

use strict;
use warnings;


my $A = [ 'a', 'b', 'c', 'd', 'e' ];
my $P = P($A);
print_A_und_P($A, $P);


sub print_A_und_P {
    my ($A, $P) = @_;

    print "A = {", join(', ', @$A), "}\n";
    print "P(A) = {\n";
    for my $p (@$P) {
        print "         {", join(', ', @$p), "},\n";
    }
    print "       }\n";
}


sub P {
    my ($A) = @_;
    my $P   = [[]];
    my $N   = scalar @$A;

    # In jedem Schleifendurchlauf der folgenden for-Schleife wird
    # die Menge der $n elementigen Mengen aus $N Elementen gebildet:
    for my $n (1..$N) {
        # $n Elemente aus $N Elementen auswaehlen:
        my @Mengen; # Menge mit Nummermengen
        for my $element (1..$n) {
            # Moegliche Nummern fuer Element $element belegen:
            my @M = $element-1 .. $N-($n-$element)-1;

            # Bei einelementigen Mengen: Mengen mit nur diesem Element
            # erzeugen:
            unless (@Mengen) {
                push @Mengen, [ $_ ] for @M;
            }

            # Anderenfalls: Jede bisherige Nummernmenge aus @Mengen
            # vervielfachen und an jede Kopie eine der neuen
            # moeglichen Nummern anhaengen:
            else {
                my @TM = @Mengen;
                @Mengen = ();
                for my $tm (@TM) {
                    for my $m (@M) {
                        unless (grep { $_ >= $m } @$tm) {
                            push @Mengen, [ @$tm, $m ];
                        }
                    }
                }
            }
        }

        # Umsetzen der Nummern auf die Elemente der Menge
        # und Abspeichern der sich ergebenden Mengen:
        for my $menge (@Mengen) {
            push @$P, [ map { $_ = $A->[$_] } @$menge ];
        }
    }

    return $P;
}

\n\n

s--Pevna-;s.([a-z]).chr((ord($1)-84)%26+97).gee; s^([A-Z])^chr((ord($1)-52)%26+65)^gee;print;

use strict; use warnings; Link zu meiner Perlseite

Taulmarill

2004-07-19 13:08

User since
2004-02-19
1750 Artikel
BenutzerIn

user image

@Crain: is meine zweite mail nicht bei dir angekommen? ich hatte noch eine berichtigte lösung geschickt.

Code: (dl )

#!/usr/local/bin/perl

use strict;
use warnings;
use Data::Dumper;

my @mengeA = qw/1 2 3/;

print Dumper funcP(@mengeA);

sub funcP {
   return ( [], rec(@_) );
}

sub rec {
   return () unless @_;

   map {
       my $first = shift @_;
       [$first], map { [ $first, @$_ ] } rec(@_);
   } @_;
}

und hier noch ne gegolfte funktion von heute morgen

Code: (dl )

sub P{sub _{@_?map{my$f=pop@_;[$f],map{[$f,@$_]}_(@_)}@_:()};[],_(@_)}

ist leider nicht kürzer als der ansatz von pq :(
dafür aber eine funktion und mehr obfuscated :p

$_=unpack"B*",~pack"H*",$_ and y&1|0& |#&&print"$_\n"for@.=qw BFA2F7C39139F45F78 0A28104594444504400 0A2F107D54447DE7800 0A2110453444450500 73CF1045138445F4800 0 F3EF2044E3D17DE 8A08A0451412411 F3CF207DF41C79E 820A20451412414 83E93C4513D17D2B

Crian

2004-07-19 13:18

User since
2003-08-04
5866 Artikel
ModeratorIn

[quote=Taulmarill,19.07.2004, 11:08]@Crain: is meine zweite mail nicht bei dir angekommen?[/quote]
Scheint so, oder ich hab sie verschlampt... ich hab diese Lösung jedenfallls mit abgespeichert.

Edit: doch ist angekommen, leider hab ich versäumt das gespeicehrte Skript upzudaten, ist jetzt nachgeholt :)\n\n

s--Pevna-;s.([a-z]).chr((ord($1)-84)%26+97).gee; s^([A-Z])^chr((ord($1)-52)%26+65)^gee;print;

use strict; use warnings; Link zu meiner Perlseite

2004-07-19 13:44

User since
2003-08-04
247 Artikel
BenutzerIn
[default_avatar]

Meine Golflösung wäre folgendes gewesen:

Code (perl): (dl )

for$a(1..2**@ARGV){print"{@ARGV[grep$a&2**$_,0..@ARGV]}"}

Alternativ könnte man noch vor dem zweiten " ein Leerzeichen reinhaun, damit die Klammern voneinander getrennt sind, oder wie bei pq ein Newline, aber ich dachte das das wohl auch als 1 Zeichen zählt... :p

Nachtrag: Bei meiner PASM-Lösung fehlen leider jede Menge Tabulatore, der liebe Beitragsparser hat wieder zugeschlagen...

Und was ich noch sagen wollte @betterworld: Kann's sein dass deine Lösung ziemlich ähnlich ausschaut?\n\n

Crian

2004-07-19 14:10

User since
2003-08-04
5866 Artikel
ModeratorIn

Deshalb werd ich die Lösungen auch wieder auf den Server stellen, dann kann sie jeder unverfälscht erhalten. Ev. mach ich diesmal auch ein Archiv mit allem, lohnt sich ja langsam ;)\n\n

s--Pevna-;s.([a-z]).chr((ord($1)-84)%26+97).gee; s^([A-Z])^chr((ord($1)-52)%26+65)^gee;print;

use strict; use warnings; Link zu meiner Perlseite

betterworld

2004-07-19 14:29

User since
2003-08-21
2613 Artikel
ModeratorIn

user image

Crian: Ich hatte Dir auch noch eine zweite Version geschickt, in der ich alles vernuenftig sortiert habe und doppelte Elemente rausgeworfen habe.

Naja, dann mache ich mich jetzt mal daran, die Algorithmen alle nachzuvollziehen :)

Soll ich meine Golf-Loesung auch noch posten oder moechte noch jemand versuchen, 57 zu unterbieten? Im Prinzip ist es der gleiche Algorithmus wie bei DS.

Lieblingsmodule: CPAN:

IPC::System::Simple, CPAN:

Path::Class

View all threads created 2004-07-16 12:08.