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]
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
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; }
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]
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
#!/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]
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
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]
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
[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
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]
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
#!/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]
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
#!/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"; }
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]