Not optimal and missing the "icycles" on the first line, but seems to work:
#! /usr/bin/perl
use warnings;
use strict;
use enum qw[ LINE POS LENGTH ];
my %string_at;
sub overlap {
my @s = @_;
my (@from, @to);
for my $string (@s) {
my ($pos, $length) = @{ $string_at{$string} }[ POS, LENGTH ];
push @from, $pos;
push @to, $pos + $length - 1;
}
if ($from[1] < $from[0]) {
@from = reverse @from;
@to = reverse @to;
}
return $to[0] >= $from[1]
}
sub output {
my @strings = sort { $string_at{$a}[LINE] <=> $string_at{$b}[LINE]
||
$string_at{$a}[POS] <=> $string_at{$b}[POS]
} keys %string_at;
my ($prev_line, $prev_pos) = (0, 0);
for my $string (@strings) {
my ($line, $pos, $length) = @{ $string_at{$string} };
if ($line != $prev_line) {
print "\n";
$prev_line = $line;
$prev_pos = 0;
}
print ' ' x ($pos - $prev_pos + 1), $string;
$prev_pos = $pos + $length + 1;
}
print "\n";
}
my %line_contains;
while (my $line = <DATA>) {
chomp $line;
my ($left_spaces) = $line =~ /^#( *)/;
my $pos = 1 + length $left_spaces;
my ($right_spaces) = $line =~ /( *)$/;
my $length = length($line) - $pos - length $right_spaces;
my $string = substr $line, $pos, $length;
$string_at{$string} = [ $. - 1, $pos, $length ];
undef $line_contains{ $. - 1 }{$string};
}
my $change = 1;
while ($change) {
undef $change;
for my $string (keys %string_at) {
TARGET:
for my $target (0 .. keys(%line_contains) - 1) {
last TARGET if exists $line_contains{$target}{$string};
for my $already (keys %{ $line_contains{$target} }) {
next TARGET if overlap($string, $already);
}
my $old_line = $string_at{$string}[LINE];
$string_at{$string}[LINE] = $target;
delete $line_contains{$old_line}{$string};
undef $line_contains{$target}{$string};
$change = 1;
last TARGET
}
}
}
output();
__DATA__
# | compressed
# | deleted
# | this
# | that
# | other
# | something else
# | and another
# foo |
# bar |
#
+ up |
#
+ down |
# s
+ideways |