http://qs321.pair.com?node_id=11118284


in reply to Divide a list of string into substrings

I don't understand all the business about scoring, but at least this gets the expected fields for the given input strings. Perhaps you can use it as a point of departure to achieve your true goals. 

c:\@Work\Perl\monks>perl -wMstrict -le
"use Test::More 'no_plan';
 use Test::NoWarnings;
 ;;
 use Data::Dump qw(dd);
 ;;
 use List::MoreUtils qw(uniq);
 ;;
 my @list = (
   'set abcde-efghi 12345',
   'set abcde-ijkl 12345',
   'clr abcde-efghi+123',
   'clr abcde-ijkl 12345',
   );
 ;;
 my @expected_substrings = (
   'set', 'clr', ' abcde-', 'efghi', 'ijkl', ' 12345', '+123',
   );
 ;;
 my $rx_fld1 = qr{       [[:alpha:]]{2,}   }xms;
 my $rx_fld2 = qr{  \s   [[:alpha:]]{2,} - }xms;
 my $rx_fld3 = qr{       [[:alpha:]]{3,}   }xms;
 my $rx_fld4 = qr{ [\s+] [[:digit:]]{2,}   }xms;
 ;;
 my (@flds1, @flds2, @flds3, @flds4);
 for my $str (@list) {
   my $parsed =
   my ($fld1, $fld2, $fld3, $fld4) =
   $str =~ m{
     \A ($rx_fld1) ($rx_fld2) ($rx_fld3) ($rx_fld4) \z
     }xms;
   die qq{'$str' parse failed} unless $parsed;
   ;;
   push @flds1, $fld1;
   push @flds2, $fld2;
   push @flds3, $fld3;
   push @flds4, $fld4;
   }
 ;;
 my @got_substrings = uniq @flds1, @flds2, @flds3, @flds4;
 dd \@got_substrings;
 ;;
 is_deeply \@got_substrings, \@expected_substrings,
           'extracted list ok';
"
["set", "clr", " abcde-", "efghi", "ijkl", " 12345", "+123"]

ok 1 - extracted list ok
ok 2 - no warnings
1..2

[download]
Note: uniq is also in List::Util in up-to-date versions of Perl; I'm testing under version 5.8.9.

Update: It occurs to me that the uniq-ifying step should be done on each sub-set individually before the sub-sets are combined together. This could be done with a
    my @got_substrings = map { uniq @$_ } \(@flds1, @flds2, @flds3, @flds4);
statement. The output list produced is the same.

Give a man a fish:  <%-{-{-{-<

Replies are listed 'Best First'.
Re^2: Divide a list of string into substrings (updated)
by Anonymous Monk on Jun 21, 2020 at 09:18 UTC

    Thanks for the nice script !

    The example should just illustrate the problem. The strings in the list can be completely different and your solution will only work with this specific example.

    There even might exists a better solution (with a lower score ($len)) for this example as the given one. I am looking for an idea how to come to a good and fast solution, accepting that this solution is not the best one, which can be found. (See also the answer of Bill)

[reply]

      I suspect there is no "good and fast" solution. This problem, to me, has the flavor of a permutation or "traveling salesman" problem, and is probably NP-hard (or one of the other NP classes).

      So here's an attempt (with a cheat) that at least gets a solution in a sort of reasonable time for this problem. 

      #!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11118281
use warnings;

my @list=("set abcde-efghi 12345",
          "set abcde-ijkl 12345",
          "clr abcde-efghi+123",
          "clr abcde-ijkl 12345");

#my @expected_substrings=("set","clr"," abcde-","efghi",
#                         "ijkl"," 12345","+123");
#my $len=@expected_substrings*2;
#$len+=length($_) foreach @expected_substrings;

$_ = join "\n", @list;
my $max = 3; ########################################### BIG CHEAT FOR
+ RUNTIME

sub score { 2 * @_ + length join '', @_; }
my $best = score( @list );

try( $_ );
print "\n";

sub try
  {
  (local $_, my @sofar) = @_;
  if( !/[ -~]/ )
    {
    my $score = score @sofar;
    if( $score < $best )
      {
      print "\n";
      use Data::Dump 'dd'; dd $score, @sofar;
      $best = $score;
      }
    return;
    }
  score(@sofar) >= $best and return;
  for my $n ( reverse 0 .. $#list )
    {
    my %d;
    /([ -~]{3,})(?:.*?\1){$n}(?{ $d{$1}++ })(*FAIL)/s;
    my @d = sort { length $b <=> length $a } sort keys %d;
    @d > $max and $#d = $max - 1;
    for my $string ( @d )
      {
      try( s/\Q$string\E/\t/gr, @sofar, $string );
      }
    }
  }

      [download]

      Outputs: 

      (46, " abcde-", " 12345", "efghi", "ijkl", "clr", "set", "+123")

      [download]

      where the "46" is the score and the rest are the substrings. As it finds better scores, it will print them, but so far always seems to find a best solution first.

[reply]
[d/l]
[select]

        Many thanks for this nice solution.

        Especially I like the way you search for equal substrings: /([ -~]{3,})(?:.*?\1){$n}(?{ $d{$1}++})(*FAIL)/s;

        I will use a lot of your ideas in my solution ...

[reply]
[d/l]

In Section Seekers of Perl Wisdom