rekursive subroutine (Allgemeines zu Perl)

[thread]18894[/thread]

rekursive subroutine

Tags: perl5 Ähnliche Threads

Leser: 21

Articles: hide open all | hide show old branches

+12 replies

kimmy

2014-02-06 14:52

User since
2010-09-10
87 Artikel
BenutzerIn
[default_avatar]

Hallo Zusammen,

ich habe folgende Liste:

Code: (dl )

[1]: a, b
[2]: c, [1]
[3]: d, e
[4]: f, [3]
[5]: g, h
[6]: i, [5]
[7]: [2], [4]
[8]: j, [6]
[9]: [7], [8]

Die Liste bedeutet:
- ein Knoten [1] hat zwei Blätter a und b
- ein Knoten [2] hat ein Blatt c und ein Knoten [1]
- usw.

Was ich haben möchte ist:

Code: (dl )

1
2
3

[7] a, b, c, d, e, f
[8] i, j, g, h
[9] [7], [8]

Mein Skript sieht wie folgt aus

Code (perl): (dl )

my (%child, @ancestor, $node, $left, $right);
$node = $1, $left = $2, $right = $3 if(/(.+?): (.+?), (.+)/);
$child{$node} = $left . ' ' . $right;   
push @ancestor, $node;

if($left =~ /^\w/ && $right =~ /^\[/){
                my $children_node = child_check($child{$right});
                $child{$node} = $left . ' ' . $children_node;
                # $right wird vom Array @ancestor entfernt
                @ancestor = grep !/^\Q$right\E$/, @ancestor;
}

foreach(@ancestor){
        my $vater_id = $_;
        my $descendant = $child{$_};
        print "$_:\t$descendant\n";
}
sub child_check{
        my $string = shift;
        my @arr_ance = split(/ /, $string);
        my @all_children;
        foreach my $ance(@arr_ance){
                if (defined $child{$ance}) {
                        my @descendants = split(/ /, $child{$ance});
                        foreach my $desc(@descendants){
                                if (defined $child{$desc}) {
                                        child_check($child{$desc});
                                }
                                else{
                                        push @all_children, $desc;
                                }
                        }               
                }
                else{
                        push @all_children, $string;
                }       
        }       
        my $join_children = join(', ', @all_children);
        return $join_children;
}

Kann jemand mir sagen, was ich falsch gemacht habe?
Last edited: 2014-02-06 15:17:48 +0100 (CET)

+3 replies
Linuxer

2014-02-06 15:03

User since
2006-01-27
3891 Artikel
HausmeisterIn

Du gibst an, was Du als Ausgangsbasis hast und was Du als Ergebnis haben willst und wie Dein Code aussieht.
Aber ich vermisse die Fehlerbeschreibung.

Was passiert denn, wenn Du Deinen Code ausführst? Was passiert nicht? Tauchen Warnungen oder Fehlermeldungen auf? Wenn ja, wie lauten diese?
meine Beiträge: I.d.R. alle Angaben ohne Gewähr und auf Linux abgestimmt!
Die Sprache heisst Perl, nicht PERL. - Bitte Crossposts als solche kenntlich machen!
- +2 replies
- kimmy
  
  2014-02-06 15:17
  User since
  2010-09-10
  87 Artikel
  BenutzerIn
  Ich bekomme keine Fehlermeldung oder Warnung. Nur ein falsches Ergenis, das ich nicht haben wollte. Wie Z.B.:
  
  Code: (dl )
  
  1 2 3 4 5
  
  [2]: c a b, a b [4]: f d e, d e [7]: [2] [4] [8]: j i g h, g h, i g h, g h, i g h, g h, i g h, g h, i g h, g h [9]: [7] [8]
  - Linuxer
    
    2014-02-06 17:54
    
    User since
    2006-01-27
    3891 Artikel
    HausmeisterIn
    
    *gelöscht weil fehlerhafte Umsetzung*
    meine Beiträge: I.d.R. alle Angaben ohne Gewähr und auf Linux abgestimmt!
    Die Sprache heisst Perl, nicht PERL. - Bitte Crossposts als solche kenntlich machen!
+2 replies

kimmy

2014-02-06 15:23

User since
2010-09-10
87 Artikel
BenutzerIn
[default_avatar]

Das ist mein Code.

Code (perl): (dl )

#!/usr/bin/perl

use strict;
use warnings;

my (%child, @ancestor); 

while(<DATA>){
        my ($node, $left, $right);
        $node = $1, $left = $2, $right = $3 if(/(.+?): (.+?), (.+)/);
        $child{$node} = $left . ' ' . $right;   
        push @ancestor, $node;

        if($left =~ /^\w/ && $right =~ /^\[/){
                my $children_node = child_check($child{$right});
                $child{$node} = $left . ', ' . $children_node;
                # $right wird vom Array @ancestor entfernt
                @ancestor = grep !/^\Q$right\E$/, @ancestor;
        }
}

foreach(@ancestor){
        #my $vater_id = $_;
        my $descendant = $child{$_};
        print "$_:\t$descendant\n";
}

sub child_check{
        my $string = shift;
        my @arr_ance = split(/ /, $string);
        my @all_children;
        foreach my $ance(@arr_ance){
                if (defined $child{$ance}) {
                        my @descendants = split(/ /, $child{$ance});
                        foreach my $desc(@descendants){
                                if (defined $child{$desc}) {
                                        child_check($child{$desc});
                                }
                                else{
                                        push @all_children, $desc;
                                }
                        }               
                }
                else{
                        push @all_children, $string;
                }       
        }       
        my $join_children = join(', ', @all_children);
        return $join_children;
}

__DATA__
[1]: a, b
[2]: c, [1]
[3]: d, e
[4]: f, [3]
[5]: g, h
[6]: i, [5]
[7]: [2], [4]
[8]: j, [6]
[9]: [7], [8]

Muffi

2014-02-06 16:13

User since
2012-07-18
1465 Artikel
BenutzerIn
[default_avatar]

Ich glaub man kann das verständlicher schreiben

Code (perl): (dl )

use strict;
use warnings;
use feature 'say';


my %nodes = ();
for my $line (<DATA>) {
        my $node = Node->new($line, \%nodes); # funktioniert nur, wenn die nodes, auf die verwiesen wird schon da sind
        $nodes{$node->id} = $node;
}

for my $node (values %nodes) {
        say $node->id.': '.join(', ', $node->elements);
}

{
        package Node;

        sub _node_id {
                my $node_ref_str = shift;
                if ($node_ref_str =~ /\[(.+)\]/) {
                        return $1;
                }
                else {
                        return undef;
                }
        }

        sub new {
                my $class = shift;
                my $str = shift;
                my $nodes = shift;
                
                my ($id, $left_str, $right_str) = $str =~ /\[(\d+)\]: (\[?\w+\]?), (\[?\w+\]?)/;

                my $left = _node_id($left_str) ? $nodes->{_node_id($left_str)} : $left_str;
                my $right = _node_id($right_str) ? $nodes->{_node_id($right_str)} : $right_str;
                my $self = { id => $id, left => $left, right => $right };
                
                bless $self, $class;
                return $self; 
        }

        sub id {
                my $self = shift;
                return $self->{id};
        }

        sub elements {
                my $self = shift;
                
                my @elements = ();
                for ('left', 'right') {
                        if ($self->{$_}->isa('Node')) {
                                push @elements, $self->{$_}->elements;
                        }
                        else {
                                push @elements, $self->{$_};
                        }
                }

                return @elements;
        }

}
__DATA__
[1]: a, b
[2]: c, [1]
[3]: d, e
[4]: f, [3]
[5]: g, h
[6]: i, [5]
[7]: [2], [4]
[8]: j, [6]
[9]: [7], [8]

Last edited: 2014-02-06 16:21:50 +0100 (CET)

1 + 1 = 10

Gast wer

2014-02-06 18:07

more (20.5kb)

Code: (dl )

[1]:a, b
[2]:c, [1]
[3]:d, e
[4]:f, [3]
[5]:g, h
[6]:i, [5]
[7]:[2], [4]
[8]:j, [6]
[9]:[7], [8]
---------------------
[2]:c, a, b
[3]:d, e
[4]:f, [3]
[5]:g, h
[6]:i, [5]
[7]:[2], [4]
[8]:j, [6]
[9]:[7], [8]
---------------------
[2]:c, a, b
[4]:f, d, e
[5]:g, h
[6]:i, [5]
[7]:[2], [4]
[8]:j, [6]
[9]:[7], [8]
---------------------
[2]:c, a, b
[4]:f, d, e
[6]:i, g, h
[7]:[2], [4]
[8]:j, [6]
[9]:[7], [8]
---------------------
[6]:i, g, h
[7]:c, a, b, f, d, e
[8]:j, [6]
[9]:[7], [8]
---------------------
[7]:c, a, b, f, d, e
[8]:j, i, g, h
[9]:[7], [8]
---------------------
[9]:c, a, b, f, d, e, j, i, g, h
---------------------
[9]:c, a, b, f, d, e, j, i, g, h

Last edited: 2014-02-06 18:10:50 +0100 (CET)

Linuxer

2014-02-06 18:13
User since
2006-01-27
3891 Artikel
HausmeisterIn
Ursprungsdaten:
Code: (dl )

1 2 3 4 5 6 7 8 9

[1]: a, b [2]: c, [1] [3]: d, e [4]: f, [3] [5]: g, h [6]: i, [5] [7]: [2], [4] [8]: j, [6] [9]: [7], [8]
Zieldaten:
Code: (dl )

1 2 3

[7] a, b, c, d, e, f [8] i, j, g, h [9] [7], [8]
Mir bleibt da einiges unklar:
- warum sind die Knoten 1-6 verschwunden?
- warum bleiben die Knoten 7 und 8 erhalten?
- warum verweist Knoten 9 nur auf die Knoten 7 und 8, anstatt Ihre Blätter zu übernehmen?
meine Beiträge: I.d.R. alle Angaben ohne Gewähr und auf Linux abgestimmt!
Die Sprache heisst Perl, nicht PERL. - Bitte Crossposts als solche kenntlich machen!

hlubenow

2014-02-06 21:54

User since
2009-02-22
877 Artikel
BenutzerIn
[default_avatar]

Ich schätze mal, Du willst voll auflösen. Das sähe bei mir so aus:

Code (perl): (dl )

#!/usr/bin/perl

use warnings;
use strict;

sub get_arr {
    my $key = shift;
    my $href = shift;
    my %h = %{$href};
    my @arr = ();
    foreach my $i (@{$h{$key}}) {
        if (exists($h{$i})) {
            push(@arr, &get_arr($i, $href));
        } else {
            push(@arr, $i);
        }
    }
    return @arr;
}

sub getHashRefFromData {
    my @d = <DATA>;
    my %h = ();
    foreach my $i (@d) {
        chomp($i);
        my @a = split(": ", $i);
        my @b = split(", ", $a[1]);
        $h{$a[0]} = [];
        foreach my $u (@b) {
            push(@{$h{$a[0]}}, $u);
        }
    }
    return \%h;
}

my $h = &getHashRefFromData();

for (my $i=1; $i<=9; $i++) {
    my $a = "[$i]";
    print "$a\t";
    my @res = &get_arr($a, $h);
    my $x = 0;
    foreach my $u (@res) {
        print "$u";
        if ($x < $#res){
            print ", ";
        }
        $x++;
    }
    print "\n";
}

__DATA__
[1]: a, b
[2]: c, [1]
[3]: d, e
[4]: f, [3]
[5]: g, h
[6]: i, [5]
[7]: [2], [4]
[8]: j, [6]
[9]: [7], [8]

Edit: Wenn man die Sache mit "__DATA__" wegläßt, kann man sich eine Funktion sparen, und es wird nochmal kürzer:

Code (perl): (dl )

#!/usr/bin/perl

use warnings;
use strict;

sub get_arr {
    my $key = shift;
    my %h = ("[1]" => ["a", "b"],
             "[2]" => ["c", "[1]"],
             "[3]" => ["d", "e"],
             "[4]" => ["f", "[3]"],
             "[5]" => ["g", "h"],
             "[6]" => ["i", "[5]"],
             "[7]" => ["[2]", "[4]"],
             "[8]" => ["j", "[6]"],
             "[9]" => ["[7]", "[8]"]);
    my @arr = ();
    foreach my $i (@{$h{$key}}) {
        if (exists($h{$i})) {
            push(@arr, &get_arr($i));
        } else {
            push(@arr, $i);
        }
    }
    return @arr;
}

for (my $i=1; $i<=9; $i++) {
    my $a = "[$i]";
    print "$a\t";
    my @res = &get_arr($a);
    foreach my $u (0 .. $#res) {
        print "$res[$u]";
        if ($u < $#res){
            print ", ";
        }
    }
    print "\n";
}

Zugegeben, "get_arr()" ist nicht der schönste Name ... ;)
Last edited: 2014-02-06 22:22:54 +0100 (CET)

+3 replies
Linuxer

2014-02-06 23:00
User since
2006-01-27
3891 Artikel
HausmeisterIn
Ist die Rekursion denn zwingend erforderlich?

Ohne das genaue Anforderungsprofil zu kennen, könnte das unten stehende auch eine Lösung sein; nur ohne Rekursion; voll auflösend mit Grundbedingungen/-annahmen.
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 33 34 35 36 37 38 39 40 41 42 43 44

#! /usr/bin/perl use strict; use warnings; my %data; while ( my $line = <DATA> ) { # skip empty or commented lines next if $line =~ m/^\s*($|#)/; chomp $line; my ( $key, @values ) = split m/\s*[:,]\s*/, $line; # resolve references to previously defined keys (and delete those when resolving) @values = sort map { m/[\d+]/ && exists $data{$_} ? @{delete $data{$_}} : $_ } @values; $data{$key} = \@values; } # check result for my $k ( sort keys %data ) { local $" = ", "; print "$k: @{$data{$k}}\n"; } # RESULT: # [9]: a, b, c, d, e, f, g, h, i, j __DATA__ # [x] : Knoten || a, b : Blaetter # - ein Knoten wird nur ein einziges Mal referenziert # - ein Knoten referenziert nur einen anderen Knoten, der zuvor definiert wurde # - wird ein Knoten referenziert, wird diese Referenz aufgelöst und durch die Blaetter ersetzt [1]: a, b [2]: c, [1] [3]: d, e [4]: f, [3] [5]: g, h [6]: i, [5] [7]: [2], [4] [8]: j, [6] [9]: [7], [8]
meine Beiträge: I.d.R. alle Angaben ohne Gewähr und auf Linux abgestimmt!
Die Sprache heisst Perl, nicht PERL. - Bitte Crossposts als solche kenntlich machen!
- +2 replies
- hlubenow
  
  2014-02-06 23:21
  
  User since
  2009-02-22
  877 Artikel
  BenutzerIn
  
  Interessant. Klappt das auch, wenn man nicht weiß, auf wievielen Ebenen zu ersetzen ist? Oder ist vielleicht in den komplexeren Funktionen (map(), usw.) irgendwo eine Rekursion versteckt?
  (Ich mein', wenn man z.B. "File::Find" verwendet, sieht man die Rekursion auch nicht, aber irgendwo im Modul wird sie sein.)
  - Linuxer
    
    2014-02-06 23:57
    
    User since
    2006-01-27
    3891 Artikel
    HausmeisterIn
    
    Das ersetzt ohne Kenntnis der Tiefe... Das einzig wichtige ist, dass die Knoten, die ersetzt werden sollen, zuvor schon definiert wurden. Solange diese Bedingung eingehalten wird, sollte das klappen.
    Die Tiefe ist irrelevant, weil so früh wie möglich der/die Knoten ersetzt werden.
    
    Ein Knoten, der noch nicht definiert wurde, kann (so) nicht ersetzt werden und bleibt einfach stehen.
    
    Mein Code innerhalb des map() verwendet keine Rekursion; was map() intern treibt, ist nicht meine Aufgabe zu beurteilen/beachten.
    meine Beiträge: I.d.R. alle Angaben ohne Gewähr und auf Linux abgestimmt!
    Die Sprache heisst Perl, nicht PERL. - Bitte Crossposts als solche kenntlich machen!

View all threads created 2014-02-06 14:52.