wg字典.pl

#!/usr/bin/perl

=head1 NAME

wg.pl


=head1 AUTHOR

Matteo Redaelli
E-MAIL: matteo.redaelli@libero.it
WEB:    http://digilander.iol.it/reda


=head1 DESCRIPTION

This is a Word Generator: you can apply some useful options to filter the 
words

=head1 USAGE

type   perl wg.pl -h


=head1 HISTORY


2000-01-06: the first lines of this script

2000-01-11 added getopt

2000-01-21: adjusted default parameters

2002-03-05: new option -n

2002-03-06: new option -s

2002-03-07: reorganization of all source code, more documentation
	


=head1 LICENSE

This package is free software; you can redistribute it and/or
modify it under the same terms as Perl itself, i.e., under the
terms of the "Artistic License" or the "GNU General Public License".


=head1 DISCLAIMER

This package is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

See the "GNU General Public License" for more details.


=cut

use Getopt::Std;
use strict;
#use integer;

sub char2string
{
# string generator: if I pass 'a' and 5, I'll get 'aaaaa'
	sprintf "%s", @_[0]  x @_[1];
}

sub occurs
{
  my $pat = @_[0];
  my $astring = @_[1];

  my $tot = $astring =~ s/$pat//g;

#	print "tot $tot\n";
#
  return $tot;
}

sub few_repeatitions
{
   my $astring = @_[0];
   my $max = @_[1];
   my $len =  length( $astring );
   my $tot = 0;

   my $mid = int( $len / 2);


   for ( my $step = 2; $step <= $mid; $step++) {
      for ( 0 .. $len - $step ) {
	my $letters = substr( $astring, $_, $step);
#	print "$letters\n";
	$tot = occurs( $letters, $astring);
	return $tot if $tot > $max;
     }
   }  
   return 0;
}

sub nple
{
	my $astring = @_[0];
	my $len = length( $astring );
	my $tot = 0;
	my $in = 0;
	my $last = ' ';

	

       for ( 0 .. $len - 1) {
               my $letter = substr( $astring, $_, 1);

#	print "$astring  $letter $last\n";
		if ( ($letter cmp $last)  == 0) {
#			print "$letter =  $last, $in, $tot";
			if ($in == 0) {
				$in = 1;
				$tot++;
			}
			
		} else {
			$in = 0;
		}		

		$last = $letter;
       }
	return $tot;

}

sub substring
{
	my $string1 = @_[0];
	my $string2 = @_[1];

	$_ = $string2;

	if ( /$string1/ ) {
		return 0;
	}
	else {
		return 1;
	}
}



my %opts;

getopts('a:c:ehl:n:o:r:tu:v:z:',  \%opts);


usage(0) if $opts{'h'};
$opts{'u'} and $opts{'v'} or usage(1);

# setup parameters

my $va_list = $opts{'v'};
my @va_list = split( //, $va_list ); # convert string to an array


my $min_depth = $opts{'l'} ? int($opts{'l'}) : 1;
my $max_depth = $opts{'u'} ? int($opts{'u'}) : 1;

usage(2) if $min_depth > $max_depth;

my $prefix = $opts{'a'} ? $opts{'a'} : '';
my $postfix = $opts{'z'} ? $opts{'z'} : '';
my $max_occurs = $opts{'o'} ? int($opts{'o'}) : $opts{'u'};
my $max_cons = $opts{'c'} ? int($opts{'c'}) : $opts{'u'};
my $max_nple =  $opts{'n'};
my $max_reps =  $opts{'r'};

usage(3) if $min_depth < 1 || 
	$max_depth < 1 || 
	$max_occurs < 1 || 
	$max_cons < 1 || 
	$max_nple < 0 || 
	$max_reps < 0;

if ($opts{'t'}) { 
	print "Options:\n";
	foreach my $key (sort keys %opts) 
		{ print "$key -> $opts{$key}\n"; }
	print "Global vars:\n";
	print_vars();
}


for ($min_depth..$max_depth) {
	wg( $_, "");
}

sub print_vars
{
	print "min_depth = $min_depth\n";
	print "max_depth =  $max_depth\n";
	print "max_occurs = $max_occurs\n";
	print "max_cons = $max_cons\n";
	print "max_nple = $max_nple\n";
	print "max_reps = $max_reps\n";
}

#
# word generator
#
sub wg
{
	my $max_depth = @_[0];
	my $myprefix = @_[1];
	my $elem;
	if ($max_depth == 0 ) {
		print "$prefix$myprefix$postfix\n";
		if ( $opts{e} == 1) {
			system "$prefix$myprefix$postfix\n";
		}
	}
	else {
#		print " n = $opts{'n'} r = $opts{'r'} \n";
#


#		suggestion: the generation of the words is more variuos if
#		I change the order of the list of the letters (@va_list)

		foreach $elem (@va_list) {

			my $newstring = "$myprefix$elem";	

			return if ( $opts{'c'} && 
				 substring(char2string( $elem , $max_cons), $myprefix ) == 0);
			return if(  $opts{'n'} && nple( $newstring ) > $max_nple);
			return if(  $opts{'r'} &&
				few_repeatitions( $newstring, $max_reps) != 0  );
			return if ( $opts{'o'} && occurs( "$elem", $newstring) > $max_occurs ); 
			
			wg( $max_depth -1, "$myprefix$elem");	
		}
	}
}

sub usage
{
	my $rc = @_[0];

	die <<END_USAGE

USAGE: perl $0 options

options are:
	-a string: prefix
	-c number: max consecutive letters (how many consecutive 'a' do you want?)
	-e : submit the output string to the operating system
	-h : help
	-l number: min length of the word
	-o number: max number of occurrencies of a letter 
	-n number: max number of n-ple  (AA, BBB, CCC, DDDD)
	-r number: max number of repeatitions (ABCABABBCDBCD has 5 repeatitions: 3 reps of AB and 2 of BCD)
	-t : trace on
	-u number: max length of the word
	-v string: list of valid characters (es, "01" "abcdef")
	-z string: postfix

possible return code are:
	0, ok
	1, not all parameters
	2, min length (-l) is greater than max lenght (-u)
	3, at least one parameter is lower than 1
Return code: $rc
END_USAGE

}