Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
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;

Log In?
Username:
Password:

What's my password?
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 musing on the Monastery: (5)
As of 2017-12-11 08:05 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    What programming language do you hate the most?




















    Results (288 votes). Check out past polls.

    Notices?