Think about Loose Coupling PerlMonks

### Two small programs for comment

by Jambo Hamon (Novice)
 on Jul 07, 2017 at 12:10 UTC ( #1194483=CUFP: print w/replies, xml ) Need Help??

Two small programs. Just putting it out there for anyone who might be interested.

First one posted generates the lexicographic ordering of balanced parenthesis. Second one finds the least number of block moves to turn one string into another string.

Both are just initial sketches but I think they do what they should.

```\$ perl balanced.pl 3
()()()
()(())
(())()
(()())
((()))
\$ perl lcs.pl jamon hamon
p=1     q=1     l=4
\$ perl lcs.pl abcdef acdegh
p=0     q=0     l=1
p=2     q=1     l=3
```#!/usr/bin/perl

=begin

Algorithm taken from:

TAOCP - D.Knuth
Vol 4 Fascicle 4
Generating All Trees
History of Combinatorial Generation
Algorithm P (Nested parenthesis in lexicographic order)

=cut

use strict;
use warnings;
use v5.10;

my \$n = shift || die "\$!: need size";
my ( \$l, \$r ) = qw! ( ) !;
my \$m;
( \$m, my @a ) = init( \$n, \$m );

my \$j;

while (1) {
visit(@a);
( \$m, @a ) = easy( \$m, @a );
next if ( \$a[\$m] eq \$l );
( \$m, \$j, @a ) = findj( \$m, @a );
last if ( \$j == 0 );
( \$m, @a ) = incj( \$m, \$j, @a );
}

sub easy {
my \$m = shift;
my @a = @_;
\$a[\$m] = \$r;
if ( \$a[ \$m - 1 ] eq \$r ) {
\$a[ \$m - 1 ] = \$l, \$m--;
}

return \$m, @a;
}

sub incj {
my \$m = shift;
my \$j = shift;
my @a = @_;
\$a[\$j] = \$l;
\$m = 2 * \$n - 1;
return \$m, @a;

}

sub findj {
my \$m = shift;
my @a = @_;
my \$j = \$m - 1;
my \$k = 2 * \$n - 1;
while ( \$a[\$j] eq \$l ) {
\$a[\$j] = \$r, \$a[\$k] = \$l, \$j--, \$k -= 2;
}
return \$m, \$j, @a;
}

sub init {
my \$n = shift;
my \$m = shift;
\$m = 2 * \$n - 1;

my @a;

for my \$k ( 1 .. \$n ) {
@a[ 2 * \$k - 1, 2 * \$k ] = ( \$l, \$r );
}
\$a[0] = \$r;
return \$m, @a;
}

sub visit {
shift;
print @_, "\n";
}
```#!/usr/bin/perl

=begin

How many block moves does it take to transform one string to another?

algorithm taken from:
the string-to-string correction probem by Walter F. Tichy
ACM Transactions on Computer Systems Vol 2 No 4 Number 1984 p. 309-321

=cut

use strict;
use warnings;
use v5.10;

my @s = split //, shift || "shanghai rulez";
my @t = split //, shift || "sakhalin rulez";

# lengths

my \$n = \$#t;
my \$m = \$#s;

my ( \$p, \$q, \$l ) = ( 0, 0, 0 );

while ( \$q <= \$n ) {
( \$p, \$l ) = f(\$q);

printf( "p=%d\tq=%d\tl=%d\n", \$p, \$q, \$l ) if ( \$l > 0 );
\$q = \$q + ( 1, \$l )[ 1 < \$l ];    # max(1,l) ... Perlmonks
}

sub f {
my (\$q)  = @_;
my \$pCur = 0;
my \$l    = 0;
my \$p    = 0;
while ( ( \$pCur + \$l <= \$m )
and ( \$q + \$l <= \$n ) )
{

my \$lCur = 0;
while ( ( \$pCur + \$lCur <= \$m )
and ( \$q + \$lCur <= \$n )
and ( \$s[ \$pCur + \$lCur ] eq \$t[ \$q + \$lCur ] ) )
{
\$lCur++;
}
if ( \$lCur > \$l ) {
\$l = \$lCur;
\$p = \$pCur;
}
\$pCur++;
}
return ( \$p, \$l );
}

Replies are listed 'Best First'.
Re: Two small programs for comment
by choroba (Bishop) on Jul 07, 2017 at 13:27 UTC
I like the first one (it would've been better to post them separately, anyway). Reminds me of the old trick of checking balanced parentheses:
```#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

my \$size = shift;
my @strings;

sub recurse {
my (\$string) = @_;
if (2 * \$size > length \$string) {
recurse(\$_ . \$string) for qw/ ( ) /;
} else {
push @strings, \$string if eval "qw(\$string) and 1";
}
}

recurse(\$_) for qw/ ( ) /;
say for sort @strings;

```(\$q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord
}map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+\$1,++print+eval\$q,q,a,
Re: Two small programs for comment
by tybalt89 (Curate) on Jul 07, 2017 at 17:22 UTC

Using a module for the second one

```#!/usr/bin/perl

# http://perlmonks.org/?node_id=1194483

use strict;
use warnings;
use Algorithm::Diff qw(traverse_sequences);

my @from = split //, shift // 'shanghai rulez';
my @to = split //, shift // 'sakhalin rulez';

my \$string = '';

traverse_sequences( \@from, \@to,
{
MATCH     => sub { \$string .= 0 },
DISCARD_A => sub { \$string .= 1 },
DISCARD_B => sub { \$string .= 2 },
} );

printf "p=%d\tq=%d\tl=%d\n", \$` =~ tr/01//, \$` =~ tr/02//, length \$&
while \$string =~ /0+/g;
Re: Two small programs for comment
by tybalt89 (Curate) on Jul 07, 2017 at 17:26 UTC

For the first one, here's a breadth first expansion solution...

```#!/usr/bin/perl -l

# http://perlmonks.org/?node_id=1194483

use strict;
use warnings;

my \$n = shift // 3;

my %seen;
my @fifo = '';

while( \$fifo[0] =~ tr/(// < \$n )
{
\$_ = shift @fifo;
!\$seen{"\$`()\$'"}++ && push @fifo, "\$`()\$'" while /()/g;
}

print for reverse sort @fifo;

Create A New User
Node Status?
node history
Node Type: CUFP [id://1194483]
Approved by herveus
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (2)
As of 2018-02-23 03:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
When it is dark outside I am happiest to see ...

Results (300 votes). Check out past polls.

Notices?