{M => [0, 2], O => [1]} #### my @pos; for my $index (0 .. $#str) { my $line = $str[$index]; for my $offset (0 .. length($line) - 1) { my $char= substr($line, $offset, 1); push @{$pos[$index]{$char}}, $offset; } } #### my $sh_str = reduce {length($a) < length($b) ? $a : $b} @str; #### [2, 1, 1] #### [[1], [1, 2], [2]] #### [1, 1, 2] [1, 2, 2] #### my (%lookup, @mapping); CHAR: for my $char (split //, $sh_str) { my @chr_pos_all_strs; for (0 .. $#pos) { # Ignore chars not in every string next CHAR if ! $pos[$_]{$char}; # All slots to be variable number of positions push @chr_pos_all_strs, $pos[$_]{$char}; } my $next = NestedLoops([@chr_pos_all_strs]); # Generate all combinations while (my @char_map = $next->()) { # stringified reference to convert back to char later my $ref = [@char_map]; $lookup{$ref} = $char; push @mapping, $ref; } } #### [1, 2, 3] is greater than [0, 0, 1] [9, 1, 5] is NOT greater than [3, 2, 1] because 1 < 2 #### my %greater; for my $i (0 .. $#chr_pos_all_strs - 1) { for my $j ($i + 1 .. $#chr_pos_all_strs) { # Skip pairs not 100% > or < each other my $gt = is_greater(@chr_pos_all_strs[$i, $j]) or next; # Always order the pairs correctly my ($lg, $sm) = $gt == 1 ? ($i, $j) : ($j, $i); # Keep track of the new pile count for the anchor ++$greater{$chr_pos_all_strs[$sm]}[CNT]; # Add the mapping to the rest of the pile push @{$greater{$chr_pos_all_strs[$sm]}[NODE]}, "$chr_pos_all_strs[$lg]"; } } sub is_greater { my ($ref1, $ref2) = @_; # Determine if the first value is greater or smaller # Return false if they are equal (can't be > or <) my $cmp = $ref1->[0] <=> $ref2->[0] or return; # For the remaining values, verify that each position # is the same as the first (> or <) # Return false otherwise ($ref1->[$_] <=> $ref2->[$_]) == $cmp || return for 1 .. $#$ref1; # Return which was greater return $cmp; } #### # A max depth watermark and a path representing that depth my ($max, $path) = (0, ''); # Work queue # 0 => path, 1 => depth, 2 => last visited leaf my @work = map [$_, 1, $_], keys %greater; #### while (@work) { my $item = pop @work; # Create lexicals to save a few dereferencing cycles my ($cur_depth, $route, $last_node) = @{$item}[DEPTH, PATH, LAST]; # Update our high water mark if appropriate ($max, $path) = ($cur_depth, $route) if $cur_depth > $max; # How many nodes are greater my $left = $greater{$last_node}[CNT]; # Finish if end of the path # Or if impossible to exceed current max depth next if ! $left || $cur_depth + $left <= $max; push @work, map ["$route:$_", $cur_depth + 1, $_], @{$greater{$last_node}[NODE]}; } #### my $hidden_msg = join '', map $lookup{$_}, split /:/, $path; return $hidden_msg;