نوشتن اعداد بر اساس حاصلضرب فاکتورهای اول آن

هر عددی را می توان بر اساس حاصلضرب مقسوم علیه های اول آن عدد نوشت . به مثالهای زیر توجه کنید :

589: 19 31
255700: 2 2 5 5 2557

می خواهیم برنامه ای بنویسیم که اعداد را از ورودی استاندارد یا از آرگومانهای فراهم شده در خط فرمان بخواند و مقسوم علیه های اول آن را پیدا کرده و خروجی به مانند بالا تولید کند . این برنامه عملیات دستور factor در سیستم های شبه یونیکس را پیاده می کند.

نکته مهم اینست که تابع find_next_prime که عدد اول بعدی را بر می گرداند علیرغم تلاش برای کاهش تعداد محاسبات هنوز کارآمد نیست . شما می توانید با داشتن دانش ریاضی و مطالعه الگوریتم های یافتن اعداد اول در اینترنت این تابع را بهینه سازی کنید .

#!/usr/local/bin/perl
#
# Mimic factor command in unix like systems :
# returns prime factors of any provided numbers
# on command line arguments or on standard input.
#
use strict;
use warnings;

# Global variable contain current prime number
# used by find_next_prime() function.
my $current_prime_number = 1;

# Find next prime number equal or greater that given number.
# Note this function is not efficient enoughly .  
sub find_next_prime {
	my $i = $current_prime_number + 1;
	my $prime;

	while (1) {
		# We assume that $i is prime number at beggining of the loop.
		$prime = 1;

		#
		# For test that a number is prime or not we must check for 
		# factors of that number in range of 2 .. sqrt(that number).
		# Obviously there are more efficient algorithmes too.
		#
		my $max = int (sqrt $i) + 1;

		# First we must find next prime number!
		for (my $j = 2; $j < $max; $j++) {
			if ($i % $j == 0) {
				# if $i % $j == 0 then $i is not prime then ...
				$prime = 0;
				last;
			}
		}
		if ($prime) {
			# $i is prime then update $current_prime_number
			$current_prime_number = $i;
			return $i;
		}

		$i++;
	}
}

sub find_factor {
	# Array to store prime factors to it.
	my @arr;
	# $number is the number we check for its prime factors.
	my $number = shift;

	# Reset $current_prime_number
	$current_prime_number = 1;
	while (1) {
		# find next prime number, it will bestored globally in $current_prime_number. 
		find_next_prime();
		# check $current_prime_number can divide $number ...
		while ($number % $current_prime_number == 0) {
			# if so push the $current_prime_number to array of calculated prime factors...
			push @arr, $current_prime_number;	
			# and update $number by dividing it to $current_prime_number.
			$number /= $current_prime_number;
		}

		# If the $number is 1 this is all done.
		last if $number == 1;
	}

	# Return the prime factors array.
	return @arr;
}

sub calc_and_print {
	my $number = shift;
	chomp $number;
	my @res = find_factor $number;
	print "$number: @res\n";
}

if (@ARGV) {
	# There is numbers provided as command line argumnets.
	while (my $c = shift) {
		calc_and_print $c;
	}
}
else {
	# No command line arguments. We must read from standard input.
	while(<STDIN>) {
		calc_and_print $_;
	}
}

نمونه استفاده از این برنامه را ببینید :

# perl fact.pl 500 9965 2588741
500: 2 2 5 5 5
9965: 5 1993
2588741: 1103 2347
# cat numbers
26541
98822214
23654141
# cat numbers | perl fact.pl
26541: 3 3 3 983
98822214: 2 3 3 3 23 251 317
23654141: 7 919 3677

مجموع عناصر زوج سری فیبوناچی کوچکتر از 4 میلیون

سری فیبوناچی دنباله ای از اعداد می باشد که با اعداد 1 و 2 شروع می شود و سپس عدد بعدی از جمع دو عدد قبل آن ایجاد می شود . دنباله اعداد زیر اولین اعداد سری فیبوناچی می باشند :

1  2  3  5  8  13  21  34  55  89  144  233

برنامه ای می نویسیم که مجموع اعداد زوج سری فیبوناچی را به شرطی که آخرین عدد حاصله کوچکتر از 4000000 باشد را بر گرداند .

#!/usr/local/bin/perl
use strict;
use warnings;

my $a = 1;
my $b = 2; 
my $c = 0;
my $sum = 2;

while (1) {
	$c  = $a + $b;
	last if ($c > 4000000);

	($a, $b) = ($b, $c);
	$sum += $c if $c % 2 == 0;
}

print "Sum of even values of Fibonacci ",
		"bellow 4000000 is: $sum\n";

خروجی برنامه به صورت زیر می باشد :

# ./fibo
Sum of even values of Fibonacci bellow 4000000 is: 4613732

پیدا کردن مجموع مضارب اعداد 3 و 5 کوچکتر از 1000

تنها نکته این برنامه اینست که اعدادی که هم مضرب 3 هستند و هم مضرب 5 می بایست تنها یکبار محاسبه شوند.

#!/usr/local/bin/perl
use strict;
use warnings;

my $i = 3;
my $s = 0;

while($i < 1000) {
	($i % 3 == 0 or $i % 5 == 0) and $s += $i;
	$i++;
}

print "Sum of multiplies of 3 and 5 bellow 1000 is: $s\n";

خروجی برنامه به صورت زیر است :

# ./3-5.pl
Sum of multiplies of 3 and 5 bellow 1000 is: 233168

فریم بندی کردن محتوای فراهم شده از فایل یا ورودی استاندارد

می خواهیم برنامه ای بنویسیم که محتوای یک یا چند فایل را بخواند و آن را به صورت فریم شده مانند زیر نمایش دهد . اگر هیچ فایل ورودی برای برنامه فراهم نشده باشد ، برنامه می بایست محتوا را از ورودی استاندارد (standard input) بخواند و همین عمل را انجام دهد .

نمونه خروجی می بایست به این صورت باشد :

**************************************************************
* total 36                                                   *
* drwxr-xr-x  2 mohsen  wheel   512B Nov 27 12:24 ./         *
* drwxr-xr-x  6 mohsen  wheel   512B Nov 25 12:45 ../        *
* -rw-r--r--  1 mohsen  wheel    30B Nov 26 21:22 b          *
* -rwxr-xr-x  1 mohsen  wheel   1.4k Nov 27 11:20 format.pl* *
* -rw-r--r--  1 mohsen  wheel   277B Nov 25 22:11 l1.pl      *
* -rw-r--r--  1 mohsen  wheel   284B Nov 25 22:50 l2.pl      *
* -rw-r--r--  1 mohsen  wheel   606B Nov 26 10:34 l3.pl      *
* -rw-r--r--  1 mohsen  wheel   348B Nov 26 12:02 l4.pl      *
* -rw-r--r--  1 mohsen  wheel   256B Nov 26 12:23 l5.pl      *
**************************************************************

تکه کد زیر این عملیات را انجام می دهد :

#!/usr/local/bin/perl
use strict;
use warnings;

# maximum length of all lines.
my $max = 0;
# store @ARGV to @arr for restoring after first traverse over @ARGV with <>.
my @arr = @ARGV;
# temp file to store data will be read from standard input.
# if no named file are provided at command line.
my $tmp_name = "$$.txt";

# if !@arr then we are reading from standard input.
# then we must open a file for writing our lines.
if (!@arr) {
	open HANDLE, ">$tmp_name" or die "Could not open temp file: $!\n";
}

while(<>) {
	chomp;
	# convert each tab character to 4 space character.
	s/\t/    /g;
	if (length > $max) {
		$max = length;
	}

	if (!@arr) {
		# Store each line in opened temporary file. 
		# We are reading from standard input.
		print HANDLE $_, "\n";
	}
}

# if !@ARGV close the opened File Handle and store
# the temporary file name in @arr to next to be restored in @ARGV;
if (!@arr) {
	close HANDLE;
	push @arr, "$tmp_name";
}

# restore @arr to @ARGV
@ARGV = @arr;
# our formating pattern require 4 more character that longest line. 
$max += 4;

# beginning to write formatted lines on standard output.
print "*" x $max, "\n";
while (<>) {
	chomp;
	# convert each tab character to 4 space character.
	s/\t/    /g;
	my $length = length;
	my $remain = $max - $length - 3;
	print "* $_";
	print " " x $remain;
	print "*\n";
}
print "*" x $max, "\n";

# if temporary file exists then delete it!
if (-e $tmp_name) {
	unlink $tmp_name or die "$!\n";
}

برنامه به صورت کامل مستند شده است . شیوه استفاده از برنامه به صورت زیر است :

# cat b
man
too
ooo
radr
baba
nan
dad
# ./format.pl b
********
* man  *
* too  *
* ooo  *
* radr *
* baba *
* nan  *
* dad  *
********
# date | ./format.pl
*********************************
* Thu Nov 27 12:41:09 IRST 2014 *
*********************************

یافتن کلمات palindrome

palindrome کلمه ایست که از ابتدا و انتها به یک صورت خوانده شود . به عنوان مثال radar و یا nan .

تکه کد زیر کلمات را از ورودی استاندارد می خواند و سپس کلمه های palindrome را در خروجی استاندارد چاپ می کند . با استفاده از سوییچ v- می توانید کلمات غیر palindrome را در خروجی استاندارد چاپ کنید .

#!/usr/local/bin/perl
#
# Read from standard input and check for
# palinrome. use -v option to check
# for non-palindrome words.
# Enter one word per line.
#
use strict;
use warnings;

# check for non-palinrome words.`
my $vflag = 0;
my $prog_name = __FILE__;

sub palindrome {
	$_ = shift @_;
	my @arr = split "", $_;

	return 0 if @arr <= 1;

	my ($i, $j) = (0, $#arr);
	
	while ($i < $j) {
		return 0 if $arr[$i] ne $arr[$j];
		$i++;
		$j--;
	}
	
	return 1;
}

#
# Usage function. Never returns.
#
sub usage {
	print STDERR "usage: $prog_name [-h -v]\n",
				"-h:show this help\n",
				"-v:show non-palindrome words\n",
				"Note: -->Read words from standard input<--\n";
	exit 1;
}

foreach (@ARGV) {
	if ($_ eq "-h") {
		usage();
		# Unreachable!
	}
	elsif ($_ eq "-v") {
		$vflag = 1;
		shift;
	}
}

my $result;
while (<STDIN>) {
	chomp;
	$result = palindrome $_;
	if ($vflag) {	
		print "$_\n" if !$result;
	}
	else {
		print "$_\n" if $result;
	}
}

 نمونه تست برنامه را مشاهده کنید :

# cat file1
man
too
ooo
radr
baba
nan
dad
# cat file1 | ./pal.pl
ooo
nan
dad
# cat file1 | ./pal.pl -v
man
too
radr
baba

محاسبه حاصل جمع عناصر یک لیست

#!/usr/local/bin/perl
#
# Compute sum of elements of a list.
# The list will be read from command line arguments.
#
use strict;
use warnings;

sub sum {	
	my $s = 0;
	$s += $_ foreach (@_);

	return $s;
}

my $s = sum @ARGV;
print "Sum of [@ARGV] = $s\n";

بازگرداندن عناصر در موقعیت زوج یک لیست

#!/usr/local/bin/perl
use strict;
use warnings;

sub array_slice {
	my $odd_or_even = shift @_;
	my @arr;
	
	my $i = $odd_or_even eq "even" ? 0 : 1;
	
	while ($i <= $#_) {
		$arr[@arr] = $_[$i];
		$i += 2;
	}	

	return @arr;
}

my @arr = array_slice "even", @ARGV;

print "Full array is: [@ARGV].\n";
print "Even position elements are: [@arr].\n";

جستجوی عدد در یک لیست

#!/usr/local/bin/perl
#
# search for an item in a numeric list.
# numeric list is privided by command line arguments.
# next we will read item to be searched from standard input.
#
use warnings;
use strict;

sub search {
	my $toSearch = shift @_;
	foreach my $i (@_) {
		return 1 if ($i == $toSearch);
	}
	return 0;
}

my $progName = __FILE__;
if (!@ARGV) {
	print STDERR "usage: $progName [num-list]\n";
	exit 1;
}

print "list is [@ARGV]. Enter what to search?! ";
my $toSearch = <STDIN>;
chomp $toSearch;

my $result = search($toSearch, @ARGV) ? "in" : "not in";
print "$toSearch is $result [@ARGV]\n";

معکوس کردن (reverse) عناصر یک لیست

#!/usr/local/bin/perl

#
# Reverse a list in place.
# list is provied as command 
# line arguments.
# 

use strict;
use warnings;

sub rev {
	my $i = 0;
	my $j = $#_;

	while ($i < $j) {
		@_[$i, $j] = @_[$j, $i];
		$i++;
		$j--;
	}

	return @_;
}

my @arr = rev @ARGV;
print "@arr\n";

پیدا کردن بزرگترین عدد یک لیست

#!/usr/local/bin/perl

# A function that returns maximum 
# number of a list. list provided
# from command line arguments.

use strict;
use warnings;

sub max {
	my $m = shift @_;
	foreach my $i (@_) {
		if ($i > $m) {
			$m = $i;
		}
	}
	return $m;
}

print max(@ARGV), "\n";