Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Block Search

by artist (Parson)
on Oct 04, 2002 at 16:14 UTC ( #202781=perlquestion: print w/replies, xml ) Need Help??

artist has asked for the wisdom of the Perl Monks concerning the following question:

Dear Monks
I want to find the largest block of similar items in the input. The code I have written is here.
#!/usr/local/bin/perl -w use strict; my $string = 'abbbcddddfegrgrgddeeeeedd'; my @chars = split //,$string; my $hold = ''; my $currentSequence = ''; my $longestSeq = ''; my $currentPosition = 0; my $longestSequenceStartPosition; foreach (@chars){ my $currentCharacter = $_; $currentPosition += 1; if($hold eq $currentCharacter){ $currentSequence .= $currentCharacter; } else{ if(length($longestSeq) < length($currentSequence)){ $longestSeq = $currentSequence; $longestSequenceStartPosition = ($currentPosition -1) - length +($longestSeq); } $currentSequence = $currentCharacter; } $hold = $currentCharacter; } print "$string\n"; print "$longestSeq\n"; my $answer = '-' x length($string); substr($answer,$longestSequenceStartPosition,length($longestSeq)) = $l +ongestSeq; print "$answer\n";
This works well if may not be efficient. It finds the first entry of largest block.
$string = 'abbbcddddfegrgrgddeeeeedd';
$answer = '------------------eeeee--'
I want to do it in a better way, find all the blocks, starting from largest to smallest and want to extend to 2-D and 3-D and may be higher dimensions. This is not from a programming contest or a homework
Thanks,
Looking for visual solution
Artist

Edit kudra, 2002-10-04 Removed unclosed pre tag

Replies are listed 'Best First'.
Re: Block Search
by davorg (Chancellor) on Oct 04, 2002 at 16:34 UTC

    I think I'd do it something .like this. If you want all of the blocks they are in @segs.

    #!/usr/bin/perl use strict; use warnings; my $string = 'abbbcddddfegrgrgddeeeeedd'; # Get repeated characters my @segs = $string =~ /((.)\2+)/g; # Filter to get only multi-char strings @segs = grep { length > 1 } @segs; # Sort @segs = sort { length $b <=> length $a } @segs; # Construct answer string my $answer = '-' x index($string, $segs[0]) . $segs[0]; $answer .= '-' x (length($string) - length($answer)); print "$string\n$answer\n";
    --
    <http://www.dave.org.uk>

    "The first rule of Perl club is you do not talk about Perl club."
    -- Chip Salzenberg

      Yep,
      That is much cleaner and more informative solution.
      Getting all the blocks is nice.
      Now How I would go about 2-D and 3-D.

      Thanks,
      Extracting the visual art
      an artist.

        As far as I understand expanding this to 2 and 3 dimensions is non trivial. Consider that video compression techniques perform this type of task. They try to find as large areas of similar color as possible. So you probably want to look into algortihms used for that. Also look in a book that has a lot of algorithm coverage of pattern matching. If the number of symbols is low then I believe there are a few useful techniques that are reasonably understandable. But unfortunately the book im thinking of isnt here. Sorry.

        --- demerphq
        my friends call me, usually because I'm late....

Re: Block Search
by waswas-fng (Curate) on Oct 04, 2002 at 16:19 UTC
    You may want to look at the source of Algorithm::Diff it has a bunch of nifty tricks for doing the same kind of things.

    Waswas
Re: Block Search
by meetraz (Hermit) on Oct 04, 2002 at 20:18 UTC
    My golf solution for this:
    $s1 = 'abbbcddddfegrgrgddeeeeedd'; print"$s1\n\n";($s2=$s1)=~s/((.)\2*)/$1,/g;map{$i=index($s1,$_);$l=len +gth;print '-'x$i,$_,'-'x(length($s1)-$i-$l),"\n";substr($s1,$i,$l,','x$l);}sort{ +length$b <=>length$a}split(/,/,$s2);
    update: shorter now
      fore! 136 chars
      #!/usr/bin/perl -wT use strict; my $s1 = 'abbbcddddfegrgrgddeeeeedd'; # 1 2 3 4 5 6 #2345678901234567890123456789012345678901234567890123456789012345678 print$s1.$/x2;push(@;,[$+[0]-$+[1],"-"x($+[1]-1).$&."-"x(length($s1) -$+[0])])while$s1=~/(.)\1*/g;print$$_[1].$/for sort{$$b[0]-$$a[0]}@;

      -Blake

        wow! ++blakem ... Can you break it down for me?
Re: Block Search
by BrowserUk (Pope) on Oct 04, 2002 at 21:34 UTC

    $_='abbbcddddfegrgrgddeeeeedd'; print+(@b=sort{(()=$b=~/./g)<=>(()=$a=~/./g)}/((.)\2+)/cg)[0] #62

    Cor! Like yer ring! ... HALO dammit! ... 'Ave it yer way! Hal-lo, Mister la-de-da. ... Like yer ring!
      If you just want to find the longest sequence, a few tweaks will bring it down to.... 47 chars
      # 1 2 3 4 #2345678901234567890123456789012345678901234567 print+(sort{$b=~y///c-$a=~y///c}/((.)\2*)/g)[0]

      -Blake

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://202781]
Approved by grinder
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (9)
As of 2019-09-19 12:25 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    The room is dark, and your next move is ...












    Results (243 votes). Check out past polls.

    Notices?