Iterative Euclid algorithm[edit]
sub gcd_iter($$) {
  my ($u, $v) = @_;
  while ($v) {
    ($u, $v) = ($v, $u % $v);
  }
  return abs($u);
}
Recursive Euclid algorithm[edit]
sub gcd($$) {
  my ($u, $v) = @_;
  if ($v) {
    return gcd($v, $u % $v);
  } else {
    return abs($u);
  }
}
Iterative binary algorithm[edit]
sub gcd_bin($$) {
  my ($u, $v) = @_;
  $u = abs($u);
  $v = abs($v);
  if ($u < $v) {
    ($u, $v) = ($v, $u);
  }
  if ($v == 0) {
    return $u;
  }
  my $k = 1;
  while ($u & 1 == 0 && $v & 1 == 0) {
    $u >>= 1;
    $v >>= 1;
    $k <<= 1;
  }
  my $t = ($u & 1) ? -$v : $u;
  while ($t) {
    while ($t & 1 == 0) {
      $t >>= 1;
    }
    if ($t > 0) {
      $u = $t;
    } else {
      $v = -$t;
    }
    $t = $u - $v;
  }
  return $u * $k;
}
Modules[edit]

# Fastest, takes multiple inputs
use Math::Prime::Util "gcd";
$gcd = gcd(49865, 69811);

# In CORE.  Slowest, takes multiple inputs, result is a Math::BigInt unless converted
use Math::BigInt;
$gcd = Math::BigInt::bgcd(49865, 69811)->numify;

# Result is a Math::Pari object unless converted
use Math::Pari "gcd";
$gcd = gcd(49865, 69811)->pari2iv
Notes on performance[edit]
use Benchmark qw(cmpthese);
use Math::BigInt;
use Math::Pari;
use Math::Prime::Util;

my $u = 40902;
my $v = 24140;
cmpthese(-5, {
  'gcd_rec' => sub { gcd($u, $v); },
  'gcd_iter' => sub { gcd_iter($u, $v); },
  'gcd_bin' => sub { gcd_bin($u, $v); },
  'gcd_bigint' => sub { Math::BigInt::bgcd($u,$v)->numify(); },
  'gcd_pari' => sub { Math::Pari::gcd($u,$v)->pari2iv(); },
  'gcd_mpu' => sub { Math::Prime::Util::gcd($u,$v); },
});

                Rate gcd_bigint   gcd_bin   gcd_rec  gcd_iter gcd_pari   gcd_mpu
gcd_bigint   39939/s         --      -83%      -94%      -95%     -98%      -99%
gcd_bin     234790/s       488%        --      -62%      -70%     -88%      -97%
gcd_rec     614750/s      1439%      162%        --      -23%     -68%      -91%
gcd_iter    793422/s      1887%      238%       29%        --     -58%      -89%
gcd_pari   1896544/s      4649%      708%      209%      139%       --      -73%
gcd_mpu    7114798/s     17714%     2930%     1057%      797%     275%        --

find the greatest common divisor (GCD), also known as greatest common factor (GCF) or greatest common measure, of two large integers. The code uses modules like Math::Cephes euclid, Math::GMPz gcd and gcd_ui for this task. It also relates to the task of finding the least common multiple.


use IO::Socket;
my $use_fork = 1;

my $sock = new IO::Socket::INET (
                                 LocalHost => '127.0.0.1',
                                 LocalPort => '12321',
                                 Proto => 'tcp',
                                 Listen => 1,   # maximum queued connections
                                 Reuse => 1,
                                )
		or die "socket: $!";	# no newline, so perl appends stuff

$SIG{CHLD} = 'IGNORE' if $use_fork;	# let perl deal with zombies

print "listening...\n";
while (1) {
	# declare $con 'my' so it's closed by parent every loop
        my $con = $sock->accept()
		or die "accept: $!";
	fork and next if $use_fork;	# following are for child only

	print "incoming..\n";
	print $con $_ while(<$con>);	# read each line and write back
	print "done\n";

	last	if $use_fork;	# if not forking, loop
}

# child will reach here and close its copy of $sock before exit

package Echo;
use base 'Net::Server::Fork';
sub process_request {
    print while <STDIN>;
}
Echo->run(port => 12321, log_level => 3);

package Echo;
use base 'Net::Server::PreFork';
sub process_request {
    print while <STDIN>;
}
Echo->run(port => 12321, log_level => 3);

implement an echo server that listens on TCP port 12321, accepts and handles multiple simultaneous connections from localhost only, and echoes back complete lines sent by clients. It also logs connection details and ensures continuous response to all clients even if one sends a partial line or stops reading responses. The server uses either multi-threading or multi-processing and supports echoing of more than one line per connection. The server also forks a new process for each client connection.


Works with: Perl version 5.8
use Scalar::Util qw(looks_like_number);
print looks_like_number($str) ? "numeric" : "not numeric\n";

Works with: Perl version 5.8

if (/\D/)            { print "has nondigits\n" }
if (/^\d+\z/)         { print "is a whole number\n" }
if (/^-?\d+\z/)       { print "is an integer\n" }
if (/^[+-]?\d+\z/)    { print "is a +/- integer\n" }
if (/^-?\d+\.?\d*\z/) { print "is a real number\n" }
if (/^-?(?:\d+(?:\.\d*)?&\.\d+)\z/) { print "is a decimal number\n" }
if (/^([+-]?)(?=\d&\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?\z/)
                     { print "a C float\n" }

sub getnum {
    use POSIX;
    my $str = shift;
    $str =~ s/^\s+//;
    $str =~ s/\s+$//;
    $! = 0;
    my($num, $unparsed) = strtod($str);
    if (($str eq '') && ($unparsed != 0) && $!) {
        return undef;
    } else {
        return $num;
    }
}

sub is_numeric { defined getnum($_[0]) }

The code is a boolean function that checks if a given string is numeric, including floating point and negative numbers. It uses Perl's internal function "looks_like_number", Data::Types functions, and regular expressions from "Regexp::Common". It also uses the "POSIX::strtod" function for POSIX systems and the String::Scanf module. The function returns the number found in the string, or "undef" if the input is not a C float.


Library: LWP
use strict;
use LWP::UserAgent;

my $url = 'https://www.rosettacode.org';
my $response = LWP::UserAgent->new->get( $url );

$response->is_success or die "Failed to GET '$url': ", $response->status_line;

print $response->as_string;

Send a GET request to the URL "https://www.w3.org/", validate the host certificate, and print the obtained resource to the console without any authentication.


implement the Sutherland-Hodgman polygon clipping algorithm. The code takes a closed polygon and a rectangle as inputs, clips the polygon by the rectangle, and outputs the sequence of points that define the resulting clipped polygon. For extra credit, the code also displays all three polygons on a graphical surface, using different colors for each polygon and filling the resulting polygon. The orientation of the display can be either north-west or south-west.


Translation of: Raku
my %scores = (
    'Solomon' => 44,
    'Jason'   => 42,
    'Errol'   => 42,
    'Garry'   => 41,
    'Bernard' => 41,
    'Barry'   => 41,
    'Stephen' => 39
);

sub tiers {
    my(%s) = @_; my(%h);
    push @{$h{$s{$_}}}, $_ for keys %s;
    @{\%h}{reverse sort keys %h};
}

sub standard {
    my(%s) = @_; my($result);
    my $rank = 1;
    for my $players (tiers %s) {
        $result .= "$rank " . join(', ', sort @$players) . "\n";
        $rank += @$players;
    }
    return $result;
}

sub modified {
    my(%s) = @_; my($result);
    my $rank = 0;
    for my $players (tiers %s) {
        $rank += @$players;
        $result .= "$rank " . join(', ', sort @$players) . "\n";
    }
    return $result;
}

sub dense {
    my(%s) = @_; my($n,$result);
    $result .= sprintf "%d %s\n", ++$n, join(', ', sort @$_) for tiers %s;
    return $result;
}

sub ordinal {
    my(%s) = @_; my($n,$result);
    for my $players (tiers %s) {
        $result .= sprintf "%d %s\n", ++$n, $_ for sort @$players;
    }
    return $result;
}

sub fractional {
    my(%s) = @_; my($result);
    my $rank = 1;
    for my $players (tiers %s) {
        my $beg = $rank;
        my $end = $rank += @$players;
        my $avg = 0;
        $avg += $_/@$players for $beg .. $end-1;
        $result .= sprintf "%3.1f %s\n", $avg, join ', ', sort @$players;
    }
    return $result;
}

print "Standard:\n"    .   standard(%scores) . "\n";
print "Modified:\n"    .   modified(%scores) . "\n";
print "Dense:\n"       .      dense(%scores) . "\n";
print "Ordinal:\n"     .    ordinal(%scores) . "\n";
print "Fractional:\n"  . fractional(%scores) . "\n";

"Implement functions for five different ranking methods: Standard, Modified, Dense, Ordinal, and Fractional. Each function takes an ordered list of competition scores and applies the respective ranking method. The Standard method shares the first ordinal number for ties, the Modified method shares the last ordinal number for ties, the Dense method shares the next available integer for ties, the Ordinal method assigns the next available integer without special treatment for ties, and the Fractional method shares the mean of the ordinal numbers for ties."


Works with: Perl version 5.8.8
use Math::Trig;

my $angle_degrees = 45;
my $angle_radians = pi / 4;

print sin($angle_radians), ' ', sin(deg2rad($angle_degrees)), "\n";
print cos($angle_radians), ' ', cos(deg2rad($angle_degrees)), "\n";
print tan($angle_radians), ' ', tan(deg2rad($angle_degrees)), "\n";
print cot($angle_radians), ' ', cot(deg2rad($angle_degrees)), "\n";
my $asin = asin(sin($angle_radians));
print $asin, ' ', rad2deg($asin), "\n";
my $acos = acos(cos($angle_radians));
print $acos, ' ', rad2deg($acos), "\n";
my $atan = atan(tan($angle_radians));
print $atan, ' ', rad2deg($atan), "\n";
my $acot = acot(cot($angle_radians));
print $acot, ' ', rad2deg($acot), "\n";

demonstrate the usage of trigonometric functions (sine, cosine, tangent, and their inverses) with the same angle in both radians and degrees. It also includes the conversion of the results of inverse functions to radians and degrees. If the language lacks these functions, the code calculates them using known approximations or identities.


#!/usr/bin/perl

use strict;

my $raw = <<'TABLE';
map     	9       150     1
compass 	13      35      1
water   	153     200     2
sandwich        50      60      2
glucose 	15      60      2
tin     	68      45      3
banana  	27      60      3
apple  		39      40      3
cheese  	23      30      1
beer    	52      10      1
suntancream     11      70      1
camera  	32      30      1
T-shirt 	24      15      2
trousers        48      10      2
umbrella        73      40      1
w_trousers     	42      70      1
w_overcoat  	43      75      1
note-case       22      80      1
sunglasses      7       20      1
towel   	18      12      2
socks   	4       50      1
book    	30      10      2
TABLE

my @items;
for (split "\n", $raw) {
        my @x = split /\s+/;
	push @items, {
		name	=> $x[0],
		weight	=> $x[1],
		value	=> $x[2],
		quant	=> $x[3],
	}
}

my $max_weight = 400;

my %cache;
sub pick {
	my ($weight, $pos) = @_;
	if ($pos < 0 or $weight <= 0) {
		return 0, 0, []
	}

	@{ $cache{$weight, $pos} //= [do{	# odd construct: for caching
		my $item = $items[$pos];
		my ($bv, $bi, $bw, $bp) = (0, 0, 0, []);

		for my $i (0 .. $item->{quant}) {
			last if $i * $item->{weight} > $weight;
			my ($v, $w, $p) = pick($weight - $i * $item->{weight}, $pos - 1);
			next if ($v += $i * $item->{value}) <= $bv;

			($bv, $bi, $bw, $bp) = ($v, $i, $w, $p);
		}

		my @picked = ( @$bp, $bi );
		$bv, $bw + $bi * $item->{weight}, \@picked
	}]}
}

my ($v, $w, $p) = pick($max_weight, $#items);
for (0 .. $#$p) {
	if ($p->[$_] > 0) {
		print "$p->[$_] of $items[$_]{name}\n";
	}
}
print "Value: $v; Weight: $w\n";

The code implements a solution to the bounded knapsack problem. It helps a tourist to determine the optimal combination of items to carry on a trip, with a weight limit of 4 kg, to maximize the total value. The items, their weights, values, and quantities are given. The solution uses recursion and caching for efficiency.


my $start = time;  # seconds since epohc
my $arlm=5;  # every 5 seconds show how we're doing
my $i;

$SIG{QUIT} = sub
   {print " Ran for ", time - $start, " seconds.\n"; die; };
$SIG{INT} = sub
   {print " Running for ", time - $start, " seconds.\n"; };
$SIG{ALRM} = sub
   {print " After $arlm  seconds i= $i. Executing for ",  time - $start, " seconds.\n";  alarm $arlm };

alarm $arlm;  # trigger ALaRM after we've run  for a while

print " ^C to inerrupt, ^\\ to quit, takes a break at $arlm seconds \n";

while ( 1 ) {
   for ( $w=11935000; $w--; $w>0 ){}; # spinning is bad, but hey it's only a demo

    print (  ++$i," \n");
            }

^C to inerrupt, ^\ to quit, takes a break at 5 seconds

After 5  seconds i= 10. Executing for 5 seconds.

After 5  seconds i= 20. Executing for 10 seconds.

use 5.010;
use AnyEvent;
my $start = AE::time;
my $exit = AE::cv;
my $int = AE::signal 'INT', $exit;
my $n;
my $num = AE::timer 0, 0.5, sub { say $n++ };
$exit->recv;
say " interrupted after ", AE::time - $start, " seconds";

The code outputs an integer every half second. When it receives a SIGINT signal (usually triggered by user typing ctrl-C) or a SIGQUIT signal (triggered by ctrl-\), it stops outputting integers, displays the total runtime in seconds, and then terminates.


sub common_prefix {
    my $sep = shift;
    my $paths = join "\0", map { $_.$sep } @_;
    $paths =~ /^ ( [^\0]* ) $sep [^\0]* (?: \0 \1 $sep [^\0]* )* $/x;
    return $1;
}

use List::Util qw(first);

sub common_prefix {
    my ($sep, @paths) = @_;
    my %prefixes;

    for (@paths) {
        do { ++$prefixes{$_} } while s/$sep [^$sep]* $//x
    }

    return first { $prefixes{$_} == @paths } reverse sort keys %prefixes;
}

my @paths = qw(/home/user1/tmp/coverage/test
               /home/user1/tmp/covert/operator
               /home/user1/tmp/coven/members);
print common_prefix('/', @paths), "\n";

The code creates a function that identifies and returns the common directory path from a set of given directory paths using a specified directory separator. It tests this function using '/' as the directory separator and three specific strings as input paths. The function ensures the returned path is a valid directory, not just the longest common string. The code also includes a solution that utilizes a regex engine to identify the common path, and another that uses a conventional method of tallying potential prefixes.


@a = 0..30;

printf "%2d ", $_ for @a; print "\n";
sattolo_cycle(\@a);
printf "%2d ", $_ for @a; print "\n";

sub sattolo_cycle {
    my($array) = @_;
    for $i (reverse 0 .. -1+@$array) {
        my $j = int rand $i;
        @$array[$j, $i] = @$array[$i, $j];
    }
}

implement the Sattolo cycle algorithm which shuffles an array ensuring each element ends up in a new position. The algorithm works by iterating from the last index to the first, selecting a random index within the range, and swapping the elements at these two indices. The algorithm modifies the input array in-place, but can be adjusted to return a new array or iterate from left to right if necessary. The key distinction from the Knuth shuffle is the range from which the random index is selected.


Library: SOAP::LiteLite
use SOAP::Lite;

print SOAP::Lite
  -> service('http://example.com/soap/wsdl')
  -> soapFunc("hello");
print SOAP::Lite
  -> service('http://example.com/soap/wsdl')
  -> anotherSoapFunc(34234);

The code establishes a SOAP client to access and call the functions soapFunc() and anotherSoapFunc() from the WSDL located at http://example.com/soap/wsdl. Note, the task and corresponding code may require further clarification.


Translation of: Python
sub median {
  my @a = sort {$a <=> $b} @_;
  return ($a[$#a/2] + $a[@a/2]) / 2;
}

The code calculates the median value of a vector of floating-point numbers. It handles even number of elements by returning the average of the two middle values. The median is found using the selection algorithm for optimal time complexity. The code also includes tasks for calculating various statistical measures like mean, mode, and standard deviation. It also calculates moving (sliding window and cumulative) averages and different types of means such as arithmetic, geometric, harmonic, quadratic, and circular.


print integers from 1 to 100, replacing multiples of three with 'Fizz', multiples of five with 'Buzz', and multiples of both with 'FizzBuzz'.


generate and draw the Mandelbrot set using various algorithms and functions. The code is an optimized translation of a Ruby solution.


my @list = ( 1, 2, 3 );

my ( $sum, $prod ) = ( 0, 1 );
$sum  += $_ foreach @list;
$prod *= $_ foreach @list;

use List::Util qw/sum0 product/;
my @list = (1..9);

say "Sum: ", sum0(@list);    # sum0 returns 0 for an empty list
say "Product: ", product(@list);

"Calculates the sum and product of an array of integers, potentially utilizing the List::Util module."


sub isleap {
    my $year = shift;
    if ($year % 100 == 0) {
        return ($year % 400 == 0);
    }
    return ($year % 4 == 0);
}

sub isleap { not $_[0] % ($_[0] % 100 ? 4 : 400) }

use Date::Manip;
print Date_LeapYear(2000);

use Date::Manip::Base;
my $dmb = new Date::Manip::Base;
print $dmb->leapyear(2000);

use DateTime;
my $date = DateTime->new(year => 2000);
print $date->is_leap_year();

determine if a given year is a leap year in the Gregorian calendar using CPAN modules functions/methods.


# 20200814 added Perl programming solution

use strict;
use warnings;

use Crypt::OTP;
use Bytes::Random::Secure qw( random_bytes );

print "Message     : ", my $message = "show me the monKey", "\n";

my $otp = random_bytes(length $message);
print "Ord(OTP)    : ", ( map { ord($_).' ' } (split //, $otp)   ) , "\n";

my $cipher = OTP( $otp, $message, 1 );
print "Ord(Cipher) : ", ( map { ord($_).' ' } (split //, $cipher) ) , "\n";

print "Decoded     : ",  OTP( $otp, $cipher, 1 ), "\n";

The code implements a One-time pad for encrypting and decrypting messages using only letters. It generates data for a One-time pad based on user-specified filename and length, ensuring the use of "true random" numbers. The encryption and decryption process is similar to Rot-13, and much of Vigenère cipher is reused with the key read from the One-time pad file. The code also optionally manages One-time pads, allowing users to list, mark as used, delete, and track which pad to use for which partner. It supports the management of pad-files with a ".1tp" extension, and handles lines starting with "#" as comments, lines starting with "-" as "used", and ignores whitespace within the otp-data.


The code is an implementation of the MD5 Message Digest Algorithm, developed directly from the algorithm specification without using built-in or external hashing libraries. It produces a correct message digest for an input string but does not mimic all calling modes. The code also includes handling of bit manipulation, unsigned integers, and little-endian data, with attention to details like boundary conditions and padding. The implementation is validated against the verification strings and hashes from RFC 1321.


#!/usr/bin/perl

my @even_numbers;

for (1..7)
{
  if ( $_ % 2 == 0)
  {
    push @even_numbers, $_;
  }
}

print "Police\tFire\tSanitation\n";

foreach my $police_number (@even_numbers)
{
  for my $fire_number (1..7)
  {
    for my $sanitation_number (1..7)
    {
      if ( $police_number + $fire_number + $sanitation_number == 12 &&
           $police_number != $fire_number &&
           $fire_number != $sanitation_number &&
           $sanitation_number != $police_number)
      {
        print "$police_number\t$fire_number\t$sanitation_number\n";
      }
    }
  }
}

#!/usr/bin/perl

use strict;   # Not necessary but considered good perl style
use warnings; # this one too

print "Police\t-\tFire\t-\tSanitation\n";
for my $p ( 1..7 )  # Police Department
{
  for my $f ( 1..7) # Fire Department
  {
    for my $s ( 1..7 ) # Sanitation Department
    {
      if ( $p % 2 == 0 && $p + $f + $s == 12 && $p != $f && $f != $s  && $s != $p && $f != $s) # Check if the combination of numbers is valid
      {
        print "$p\t-\t$f\t-\t$s\n";
      }
    }
  }
}

Police  -       Fire    -       Sanitation
2       -       3       -       7
2       -       4       -       6
2       -       6       -       4
2       -       7       -       3
4       -       1       -       7
4       -       2       -       6
4       -       3       -       5
4       -       5       -       3
4       -       6       -       2
4       -       7       -       1
6       -       1       -       5
6       -       2       -       4
6       -       4       -       2
6       -       5       -       1

Alternate with Regex[edit]
#!/usr/bin/perl

use strict; # https://rosettacode.org/wiki/Department_numbers
use warnings;

print "P S F\n\n";

'246 1234567 1234567' =~
  /(.).* \s .*?(?!\1)(.).* \s .*(?!\1)(?!\2)(.)
  (??{$1+$2+$3!=12})
  (?{ print "@{^CAPTURE}\n" })(*FAIL)/x;

generate all valid combinations of numbers between 1 and 7 (inclusive) for three departments (police, sanitation, fire) in a city. The numbers must be unique, add up to 12, and the police department number must be even.


my $original = 'Hello.';
my $new = $original;
$new = 'Goodbye.';
print "$original\n";   # prints "Hello."

my $original = 'Hello.';
my $ref = \$original;
$$ref = 'Goodbye.';
print "$original\n";   # prints "Goodbye."

my $original = 'Hello.';
our $alias;
local *alias = \$original;
$alias = 'Good evening.';
print "$original\n";   # prints "Good evening."

use Lexical::Alias;
my $original = 'Hello.';
my $alias;
alias $alias, $original;
$alias = 'Good evening.';
print "$original\n";   # prints "Good evening."

demonstrate how to copy a string, create a reference to an existing string, assign a new name to the same string, and make a lexical variable as an alias of another variable using the Lexical::Alias module in Perl. It also highlights the dynamic binding of local variables and the potential modifications by subroutines within the same scope.


sub F { my $n = shift; $n ? $n - M(F($n-1)) : 1 }
sub M { my $n = shift; $n ? $n - F(M($n-1)) : 0 }

# Usage:
foreach my $sequence (\&F, \&M) {
    print join(' ', map $sequence->($_), 0 .. 19), "\n";
}

implement two mutually recursive functions to compute the Hofstadter Female and Male sequences. If the programming language does not support mutual recursion, it should be stated.


my @array = qw(a b c);
print $array[ rand @array ];

demonstrate how to select a random element from a list.


sub urldecode {
    my $s = shift;
    $s =~ tr/\+/ /;
    $s =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/eg;
    return $s;
}

print urldecode('http%3A%2F%2Ffoo+bar%2F')."\n";

#!/usr/bin/perl -w
use strict ;
use URI::Escape ;

my $encoded = "http%3A%2F%2Ffoo%20bar%2F" ;
my $unencoded = uri_unescape( $encoded ) ;
print "The unencoded string is $unencoded !\n" ;

provide a function to convert URL-encoded strings back into their original unencoded form. It includes test cases for strings like "http%3A%2F%2Ffoo%20bar%2F", "google.com/search?q=%60Abdu%27l-Bah%C3%A1", and "%25%32%35".


sub binary_search {
    my ($array_ref, $value, $left, $right) = @_;
    while ($left <= $right) {
        my $middle = int(($right + $left) >> 1);
        if ($value == $array_ref->[$middle]) {
            return $middle;
        }
        elsif ($value < $array_ref->[$middle]) {
            $right = $middle - 1;
        }
        else {
            $left = $middle + 1;
        }
    }
    return -1;
}

sub binary_search {
    my ($array_ref, $value, $left, $right) = @_;
    return -1 if ($right < $left);
    my $middle = int(($right + $left) >> 1);
    if ($value == $array_ref->[$middle]) {
        return $middle;
    }
    elsif ($value < $array_ref->[$middle]) {
        binary_search($array_ref, $value, $left, $middle - 1);
    }
    else {
        binary_search($array_ref, $value, $middle + 1, $right);
    }
}

The code implements a binary search algorithm to find a specific number in a sorted integer array. It includes both recursive and iterative versions of the algorithm. The binary search algorithm divides the range of values into halves and continues to narrow down the search field until the target value is found. The code also handles cases of multiple equal values and returns the index of the target value if found. Additionally, it provides the leftmost and rightmost insertion points for the target value. The code also includes a fix for potential overflow bugs.


Works with: Perl version 5.x

my @params = @ARGV;
my $params_size = @ARGV;
my $second = $ARGV[1];
my $fifth = $ARGV[4];

use Getopt::Long;
GetOptions (
    'help|h'     => \my $help,
    'verbose|v'  => \my $verbose,
);

"Code retrieves and prints the list of command-line arguments given to the program. It uses @ARGV array to store all command-line parameters. Also, it provides an option to import a module if needed. Example command line usage is 'myprogram -c "alpha beta" -h "gamma"'. For intelligent parsing of these arguments, refer to 'Parsing command-line arguments'."


Library: Perl/Tk
Translation of: Tcl

use strict;
use warnings;
use Tk;
use Math::Trig qw/:pi/;

my $root =  new MainWindow( -title => 'Pendulum Animation' );
my $canvas = $root->Canvas(-width => 320, -height => 200);
my $after_id;

for ($canvas) {
	$_->createLine(   0,  25, 320,  25, -tags => [qw/plate/], -width => 2, -fill => 'grey50' );
	$_->createOval( 155,  20, 165,  30, -tags => [qw/pivot outline/], -fill => 'grey50' );
	$_->createLine(   1,   1,    1,  1, -tags => [qw/rod width/], -width => 3, -fill => 'black' );
	$_->createOval(   1,   1,    2,  2, -tags => [qw/bob outline/], -fill => 'yellow' );
}

$canvas->raise('pivot');
$canvas->pack(-fill => 'both', -expand => 1);
my ($Theta, $dTheta, $length, $homeX, $homeY) =
	(45, 0, 150, 160, 25);

sub show_pendulum {
  my $angle = $Theta * pi() / 180;
  my $x = $homeX + $length * sin($angle);
  my $y = $homeY + $length * cos($angle);
  $canvas->coords('rod', $homeX, $homeY, $x, $y);
  $canvas->coords('bob', $x-15, $y-15, $x+15, $y+15);
}

sub recompute_angle {
  my $scaling = 3000.0 / ($length ** 2);
  # first estimate
  my $firstDDTheta = -sin($Theta * pi / 180) * $scaling;
  my $midDTheta = $dTheta + $firstDDTheta;
  my $midTheta = $Theta + ($dTheta + $midDTheta)/2;
  # second estimate
  my $midDDTheta = -sin($midTheta * pi/ 180) * $scaling;
  $midDTheta = $dTheta + ($firstDDTheta + $midDDTheta)/2;
  $midTheta = $Theta + ($dTheta + $midDTheta)/2;
  # again, first
  $midDDTheta = -sin($midTheta * pi/ 180) * $scaling;
  my $lastDTheta = $midDTheta + $midDDTheta;
  my $lastTheta = $midTheta + ($midDTheta + $lastDTheta)/2;
  # again, second
  my $lastDDTheta = -sin($lastTheta * pi/180) * $scaling;
  $lastDTheta = $midDTheta + ($midDDTheta + $lastDDTheta)/2;
  $lastTheta = $midTheta + ($midDTheta + $lastDTheta)/2;
  # Now put the values back in our globals
  $dTheta  = $lastDTheta;
  $Theta = $lastTheta;
}

sub animate {
  recompute_angle;
  show_pendulum;
  $after_id = $root->after(15 => sub {animate() });
}

show_pendulum;
$after_id = $root->after(500 => sub {animate});

$canvas->bind('<Destroy>' => sub {$after_id->cancel});
MainLoop;

simulate and animate a simple gravity pendulum model, without window resizing handling functionality.


Library: JSON
use JSON;

my $data = decode_json('{ "foo": 1, "bar": [10, "apples"] }');

my $sample = { blue => [1,2], ocean => "water" };
my $json_string = encode_json($sample);

"Load a JSON string into a data structure, create a new data structure, serialize it into JSON, and validate the JSON."


Implement the principal nth root algorithm for a positive real number A.


Works with: Perl version 5.8.6
Library: Sys::HostnameHostname
use Sys::Hostname;

$name = hostname;

"Determines and outputs the hostname of the current system where the routine is running."


no warnings 'experimental::signatures';
use feature 'signatures';

sub leonardo ($n, $l0 = 1, $l1 = 1, $add = 1) {
  ($l0, $l1) = ($l1, $l0+$l1+$add)  for 1..$n;
  $l0;
}

my @L = map { leonardo($_) } 0..24;
print "Leonardo[1,1,1]: @L\n";
my @F = map { leonardo($_,0,1,0) } 0..24;
print "Leonardo[0,1,0]: @F\n";

generate the first 25 Leonardo numbers, starting from L(0), with the ability to specify the first two Leonardo numbers and the add number. The codes also have the functionality to generate the Fibonacci sequence by specifying 0 and 1 for L(0) and L(1), and 0 for the add number.


#!/usr/bin/env perl
use warnings;
use strict;
use feature 'say';

print <<'EOF';
The 24 Game

Given any four digits in the range 1 to 9, which may have repetitions,
Using just the +, -, *, and / operators; and the possible use of
parentheses, (), show how to make an answer of 24.

An answer of "q" or EOF will quit the game.
A blank answer will generate a new set of four digits.
Otherwise you are repeatedly asked for an expression until it evaluates to 24.

Note: you cannot form multiple digit numbers from the supplied digits,
so an answer of 12+12 when given 1, 2, 2, and 1 would not be allowed.
EOF

my $try = 1;
while (1) {
  my @digits = map { 1+int(rand(9)) } 1..4;
  say "\nYour four digits: ", join(" ", @digits);
  print "Expression (try ", $try++, "): ";

  my $entry = <>;
  if (!defined $entry || $entry eq 'q')
    { say "Goodbye.  Sorry you couldn't win."; last; }
  $entry =~ s/\s+//g;  # remove all white space
  next if $entry eq '';

  my $given_digits = join "", sort @digits;
  my $entry_digits = join "", sort grep { /\d/ } split(//, $entry);
  if ($given_digits ne $entry_digits ||  # not correct digits
      $entry =~ /\d\d/ ||                # combined digits
      $entry =~ m|[-+*/]{2}| ||          # combined operators
      $entry =~ tr|-0-9()+*/||c)         # Invalid characters
    { say "That's not valid";  next; }

  my $n = eval $entry;

  if    (!defined $n) { say "Invalid expression"; }
  elsif ($n == 24)    { say "You win!"; last; }
  else                { say "Sorry, your expression is $n, not 24"; }
}

"Generate a game that randomly selects four digits and prompts the user to create an arithmetic expression with these digits that equals 24. The code checks and evaluates the user's expression, allowing for addition, subtraction, multiplication, and division operations. The code does not allow the formation of multiple digit numbers from the given digits."


sub encode {
    shift =~ s/(.)\1*/length($&).$1/grse;
}

sub decode {
    shift =~ s/(\d+)(.)/$2 x $1/grse;
}

sub encode {
    shift =~ s/(.)\1{0,254}/pack("C", length($&)).$1/grse;
}

sub decode {
    shift =~ s/(.)(.)/$2 x unpack("C", $1)/grse;
}

sub encode {
    my $str = shift;
    my $ret = "";
    my $nonrep = "";
    while ($str =~ m/(.)\1{0,127}|\z/gs) {
        my $len = length($&);
        if (length($nonrep) && (length($nonrep) == 127 || $len != 1)) {
            $ret .= pack("C", 128 + length($nonrep)) . $nonrep;
            $nonrep = "";
        }
        if    ($len == 1) { $nonrep .= $1 }
        elsif ($len > 1)  { $ret .= pack("C", $len) . $1 }
    }
    return $ret;
}

sub decode {
    my $str = shift;
    my $ret = "";
    for (my $i = 0; $i < length($str);) {
        my $len = unpack("C", substr($str, $i, 1));
        if ($len <= 128) {
            $ret .= substr($str, $i + 1, 1) x $len;
            $i += 2;
        }
        else {
            $ret .= substr($str, $i + 1, $len - 128);
            $i += 1 + $len - 128;
        }
    }
    return $ret;
}

use Data::Dump qw(dd);
dd my $str = "XXXXXABCDEFGHIoooooooooooooooooooooooooAAAAAA";
dd my $enc = encode($str);
dd decode($enc);

implement a run-length encoding and decoding system. The codes compress repeated runs of the same uppercase character in a string by storing the length of the run. It also provides a function to reverse the compression. The codes can handle arbitrary byte strings as input and support compact representation of longer non-repeating substrings.


my $s = 'hello';
print $s . ' literal', "\n";
my $s1 = $s . ' literal';
print $s1, "\n";

$s .= ' literal';
print $s, "\n";

Create a string variable, concatenate it with another string, and display the result.


sub urlencode {
    my $s = shift;
    $s =~ s/([^-A-Za-z0-9_.!~*'() ])/sprintf("%%%02X", ord($1))/eg;
    $s =~ tr/ /+/;
    return $s;
}

print urlencode('http://foo bar/')."\n";

The code provides a function to convert a given string into URL encoding format. It converts special, control, and extended characters into a percent symbol followed by a two-digit hexadecimal code. Characters other than 0-9, A-Z, and a-z are converted. The function also supports variations like lowercase escapes and different encodings for special characters according to different standards like RFC 3986, HTML 5, and encodeURI function in Javascript. An optional feature allows the use of an exception string containing symbols that don't need conversion.


generates a common sorted list with unique elements from multiple integer arrays.


determine the optimal combination of items a thief can steal from a butcher's shop without exceeding a total weight of 15 kg in his knapsack, with the possibility of cutting items proportionally to their original price, in order to maximize the total value.


use List::Util 'max';

my @words = split "\n", do { local( @ARGV, $/ ) = ( 'unixdict.txt' ); <> };
my %anagram;
for my $word (@words) {
    push @{ $anagram{join '', sort split '', $word} }, $word;
}

my $count = max(map {scalar @$_} values %anagram);
for my $ana (values %anagram) {
    print "@$ana\n" if @$ana == $count;
}

push @{$anagram{ join '' => sort split '' }}, $_ for @words;
$max > @$_  or  $max = @$_    for values %anagram;
@$_ == $max and print "@$_\n" for values %anagram;

find the sets of words from the provided URL that are anagrams of each other, i.e., composed of the same characters but in a different order. The code specifically identifies the sets with the most words in them. The calculation of $max eliminates the need for the CPAN module.


generate a graphical or ASCII-art representation of a Sierpinski carpet of a given order N. The representation uses whitespace and non-whitespace characters, with the non-whitespace character not strictly required to be '#'. The placement of these characters follows the pattern of a Sierpinski carpet.


use 5.10.0;
use strict;

# produce encode and decode dictionary from a tree
sub walk {
	my ($node, $code, $h, $rev_h) = @_;

	my $c = $node->[0];
	if (ref $c) { walk($c->[$_], $code.$_, $h, $rev_h) for 0,1 }
	else        { $h->{$c} = $code; $rev_h->{$code} = $c }

	$h, $rev_h
}

# make a tree, and return resulting dictionaries
sub mktree {
	my (%freq, @nodes);
	$freq{$_}++ for split '', shift;
	@nodes = map([$_, $freq{$_}], keys %freq);

	do {	# poor man's priority queue
		@nodes = sort {$a->[1] <=> $b->[1]} @nodes;
		my ($x, $y) = splice @nodes, 0, 2;
		push @nodes, [[$x, $y], $x->[1] + $y->[1]]
	} while (@nodes > 1);

	walk($nodes[0], '', {}, {})
}

sub encode {
	my ($str, $dict) = @_;
	join '', map $dict->{$_}//die("bad char $_"), split '', $str
}

sub decode {
	my ($str, $dict) = @_;
	my ($seg, @out) = ("");

	# append to current segment until it's in the dictionary
	for (split '', $str) {
		$seg .= $_;
		my $x = $dict->{$seg} // next;
		push @out, $x;
		$seg = '';
	}
	die "bad code" if length($seg);
	join '', @out
}

my $txt = 'this is an example for huffman encoding';
my ($h, $rev_h) = mktree($txt);
for (keys %$h) { print "'$_': $h->{$_}\n" }

my $enc = encode($txt, $h);
print "$enc\n";

print decode($enc, $rev_h), "\n";

The code generates a Huffman encoding for each character in the given string "this is an example for huffman encoding". It first creates a tree of nodes based on the frequency of each character. Then, it traverses the tree from root to leaves, assigning '0' for one branch and '1' for the other at each node. The accumulated zeros and ones at each leaf constitute a Huffman encoding for those characters. The output is a table of Huffman encodings for each character.


Library: Perl/Tk[edit]
use Tk;

$main = MainWindow->new;
$l = $main->Label('-text' => 'There have been no clicks yet.')->pack;
$count = 0;
$main->Button(
  -text => ' Click Me ',
  -command => sub { $l->configure(-text => 'Number of clicks: '.(++$count).'.'); },
)->pack;
MainLoop();

Library: GTK Works with: Perl/Gtk[edit]
use Gtk '-init';

# Window.
$window = Gtk::Window->new;
$window->signal_connect('destroy' => sub { Gtk->main_quit; });

# VBox.
$vbox = Gtk::VBox->new(0, 0);
$window->add($vbox);

# Label.
$label = Gtk::Label->new('There have been no clicks yet.');
$vbox->add($label);

# Button.
$count = 0;
$button = Gtk::Button->new(' Click Me ');
$vbox->add($button);
$button->signal_connect('clicked', sub {
  $label->set_text(++$count);
});

# Show.
$window->show_all;

# Main loop.
Gtk->main;

Implement a windowed application with a label and a button. The label initially displays "There have been no clicks yet". The button, labelled "click me", updates the label to show the number of times it has been clicked when interacted with.


use DBI;

my $db = DBI->connect('DBI:mysql:database:server','login','password');

my $statment = <<EOF;
CREATE TABLE `Address` (
    `addrID`       int(11)     NOT NULL   auto_increment,
    `addrStreet`   varchar(50) NOT NULL   default '',
    `addrCity`     varchar(25) NOT NULL   default '',
    `addrState`    char(2)     NOT NULL   default '',
    `addrZIP`      char(10)    NOT NULL   default '',
    PRIMARY KEY (`addrID`)
);
EOF

my $exec = $db->prepare($statment);
$exec->execute;

"Creates a table in a chosen database to store US postal addresses, including fields for unique identifier, street address, city, state code, and zipcode. Also demonstrates how to open a database connection in non-database languages."


foreach (reverse 0..10) {
  print "$_\n";
}

The code performs a countdown from 10 to 0 using a downward for loop.


if( @ARGV != 3 ){
  printHelp();
}

  # translate to upper-case, remove anything else
map( (tr/a-z/A-Z/, s/[^A-Z]//g), @ARGV );

my $cipher_decipher = $ARGV[ 0 ];

if( $cipher_decipher !~ /ENC|DEC/ ){
  printHelp();  # user should say what to do
}

print "Key: " . (my $key = $ARGV[ 2 ]) . "\n";

if( $cipher_decipher =~ /ENC/ ){
  print "Plain-text: " . (my $plain = $ARGV[ 1 ]) . "\n";
  print "Encrypted: " . Vigenere( 1, $key, $plain ) . "\n";
}elsif( $cipher_decipher =~ /DEC/ ){
  print "Cipher-text: " . (my $cipher = $ARGV[ 1 ]) . "\n";
  print "Decrypted: " . Vigenere( -1, $key, $cipher ) . "\n";
}

sub printHelp{
  print "Usage:\n" .
        "Encrypting:\n perl cipher.pl ENC (plain text) (key)\n" .
        "Decrypting:\n perl cipher.pl DEC (cipher text) (key)\n";
  exit -1;
}

sub Vigenere{
  my ($direction, $key, $text) = @_;
  for( my $count = 0; $count < length $text; $count ++ ){
    $key_offset = $direction * ord substr( $key, $count % length $key, 1);
    $char_offset = ord substr( $text, $count, 1 );
    $cipher .= chr 65 + ((($char_offset % 26) + ($key_offset % 26)) % 26);
      # 65 is the ASCII character code for 'A'
  }
  return $cipher;
}

$ perl cipher.pl ENC 'Beware the Jabberwock, my son! The jaws that bite, the claws that catch!' VIGENERECIPHER
Key: VIGENERECIPHER
Plain-text: BEWARETHEJABBERWOCKMYSONTHEJAWSTHATBITETHECLAWSTHATCATCH
Encrypted: WMCEEIKLGRPIFVMEUGXQPWQVIOIAVEYXUEKFKBTALVXTGAFXYEVKPAGY

$ perl cipher.pl DEC WMCEEIKLGRPIFVMEUGXQPWQVIOIAVEYXUEKFKBTALVXTGAFXYEVKPAGY VIGENERECIPHER
Key: VIGENERECIPHER
Cipher-text: WMCEEIKLGRPIFVMEUGXQPWQVIOIAVEYXUEKFKBTALVXTGAFXYEVKPAGY
Decrypted: BEWARETHEJABBERWOCKMYSONTHEJAWSTHATBITETHECLAWSTHATCATCH

$ perl cipher.pl FOO WMCEEIKLGRPIFVMEUGXQPWQVIOIAVEYXUEKFKBTALVXTGAFXYEVKPAGY VIGENERECIPHER
Usage:
Encrypting:
 perl cipher.pl ENC (plain text) (key)
Decrypting:
 perl cipher.pl DEC (cipher text) (key)

Implement and demonstrate a Vigenère cipher for both encryption and decryption. The code handles keys and text of unequal length, capitalizes all characters, and discards non-alphabetic characters. If non-alphabetic characters are handled differently, it is noted in the code.


for($i=2; $i <= 8; $i += 2) {
  print "$i, ";
}
print "who do we appreciate?\n";

demonstrate a for-loop with a step-value greater than one.


"Implement Jensen's Device, a programming technique that exploits call by name for parameter passing. The program computes the 100th harmonic number using a summation function, which takes in a bound variable and an expression, both passed by name. The result is dependent on the re-evaluation of the expression in the caller's context each time the parameter's value is required. The output is 5.18737751763962."


use GD;

my $img = GD::Image->new(256, 256, 1);

for my $y (0..255) {
        for my $x (0..255) {
                my $color = $img->colorAllocate( abs(255 - $x - $y),  (255-$x) ^ $y , $x ^ (255-$y));
                $img->setPixel($x, $y, $color);
        }
}

print $img->png

generates a graphical pattern by coloring each pixel based on the 'x xor y' value from a given color table, implementing the Munching Squares algorithm.


generate a maze using the Depth-first search algorithm. It starts at a random cell, marks it as visited, and gets a list of its neighbors. For each neighbor, it checks if it's visited, removes the wall between the current cell and the neighbor if not, and then recurses with the neighbor as the current cell. The maze can be run with custom width and height or use default dimensions.


The code continuously calculates and outputs the next decimal digit of Pi, starting from 3.14159265. The program runs indefinitely until manually stopped by the user. It uses various methods and libraries like Math::BigInt::GMP, Raku spigot, and Machin's formula for the calculation. The performance can be significantly improved by using Math::GMP instead of bigint. It doesn't require any modules or bigints. The code also accepts a number-of-digits argument to specify the precision of the calculation.


use strict;
use warnings;

sub orderlists {
    my ($firstlist, $secondlist) = @_;

    my ($first, $second);
    while (@{$firstlist}) {
        $first = shift @{$firstlist};
        if (@{$secondlist}) {
            $second = shift @{$secondlist};
            if ($first < $second) {
                return 1;
            }
            if ($first > $second) {
                return 0;
            }
        }
        else {
            return 0;
        }
    }

    @{$secondlist} ? 1 : 0;
}

foreach my $pair (
    [[1, 2, 4], [1, 2, 4]],
    [[1, 2, 4], [1, 2,  ]],
    [[1, 2,  ], [1, 2, 4]],
    [[55,53,1], [55,62,83]],
    [[20,40,51],[20,17,78,34]],
) {
    my $first  = $pair->[0];
    my $second = $pair->[1];
    my $before = orderlists([@$first], [@$second]) ? 'true' : 'false';
    print "(@$first) comes before (@$second) : $before\n";
}

"Function to compare and order two numerical lists lexicographically, returning true if the first list should be ordered before the second, and false otherwise."


The code implements the Ackermann function, a non-primitive recursive function, which takes two non-negative integers as arguments and returns their Ackermann value. The function is optimized for larger values by memoizing calls and using a stack instead of recursion. The function also supports arbitrary precision due to the rapid growth of the Ackermann function.


implement the Gamma function using either the Lanczos or Stirling's approximation. The codes also compare the results of the custom implementation with the built-in/library function if available. The Gamma function is computed through numerical integration.


my ($board_size, @occupied, @past, @solutions);

sub try_column {
        my ($depth, @diag) = shift;
        if ($depth == $board_size) {
                push @solutions, "@past\n";
                return;
        }

        # @diag: marks cells diagonally attackable by any previous queens.
        #        Here it's pre-allocated to double size just so we don't need
        #        to worry about negative indices.
        $#diag = 2 * $board_size;
        for (0 .. $#past) {
                $diag[ $past[$_] + $depth - $_ ] = 1;
                $diag[ $past[$_] - $depth + $_ ] = 1;
        }

        for my $row (0 .. $board_size - 1) {
                next if $occupied[$row] || $diag[$row];

                # @past:     row numbers of previous queens
                # @occupied: rows already used. This gets inherited by each
                #            recursion so we don't need to repeatedly look them up
                push @past, $row;
                $occupied[$row] = 1;

                try_column($depth + 1);

                # clean up, for next recursion
                $occupied[$row] = 0;
                pop @past;
        }
}

$board_size = 12;
try_column(0);

#print for @solutions; # un-comment to see all solutions
print "total " . @solutions . " solutions\n";

"Solve the N-queens problem for an NxN board and provide the number of solutions for small values of N."


demonstrate how to concatenate two arrays in Perl using the push function.


my $raw = <<'TABLE';
map			9	150
compass			13	35
water			153	200
sandwich		50	160
glucose			15	60
tin			68	45
banana			27	60
apple			39	40
cheese			23	30
beer			52	10
suntancream		11	70
camera			32	30
T-shirt			24	15
trousers		48	10
umbrella		73	40
waterproof trousers	42	70
waterproof overclothes	43	75
note-case		22	80
sunglasses		7	20
towel			18	12
socks			4	50
book			30	10
TABLE

my (@name, @weight, @value);
for (split "\n", $raw) {
    for ([ split /\t+/ ]) {
        push @name,   $_->[0];
        push @weight, $_->[1];
        push @value,  $_->[2];
    }
}

my $max_weight = 400;
my @p = map [map undef, 0 .. 1+$max_weight], 0 .. $#name;

sub optimal {
    my ($i, $w) = @_;
    return [0, []] if $i < 0;
    return $p[$i][$w] if $p[$i][$w];

    if ($weight[$i] > $w) {
        $p[$i][$w] = optimal($i - 1, $w)
    } else {
        my $x = optimal($i - 1, $w);
        my $y = optimal($i - 1, $w - $weight[$i]);

        if ($x->[0] > $y->[0] + $value[$i]) {
            $p[$i][$w] = $x
        } else {
            $p[$i][$w] = [  $y->[0] + $value[$i], [ @{$y->[1]}, $name[$i] ]]
        }
    }
    return $p[$i][$w]
}

my $solution = optimal($#name, $max_weight);
print "$solution->[0]: @{$solution->[1]}\n";

<output> implement a solution to the 0-1 Knapsack problem. The codes determine the optimal combination of items a tourist can carry in his knapsack, given a maximum weight limit of 4kg, to maximize the total value of the items. The items, their weights, and their values are provided in a list, and only whole units of any item can be taken. </output>


#!/usr/bin/env perl
use strict;
use warnings;
use feature qw/say/;
use List::Util qw(first);

my %Likes = (
  M => {
    abe  => [qw/ abi eve cath ivy jan dee fay bea hope gay /],
    bob  => [qw/ cath hope abi dee eve fay bea jan ivy gay /],
    col  => [qw/ hope eve abi dee bea fay ivy gay cath jan /],
    dan  => [qw/ ivy fay dee gay hope eve jan bea cath abi /],
    ed   => [qw/ jan dee bea cath fay eve abi ivy hope gay /],
    fred => [qw/ bea abi dee gay eve ivy cath jan hope fay /],
    gav  => [qw/ gay eve ivy bea cath abi dee hope jan fay /],
    hal  => [qw/ abi eve hope fay ivy cath jan bea gay dee /],
    ian  => [qw/ hope cath dee gay bea abi fay ivy jan eve /],
    jon  => [qw/ abi fay jan gay eve bea dee cath ivy hope /],
  },

  W => {
    abi  => [qw/ bob fred jon gav ian abe dan ed col hal /],
    bea  => [qw/ bob abe col fred gav dan ian ed jon hal /],
    cath => [qw/ fred bob ed gav hal col ian abe dan jon /],
    dee  => [qw/ fred jon col abe ian hal gav dan bob ed /],
    eve  => [qw/ jon hal fred dan abe gav col ed ian bob /],
    fay  => [qw/ bob abe ed ian jon dan fred gav col hal /],
    gay  => [qw/ jon gav hal fred bob abe col ed dan ian /],
    hope => [qw/ gav jon bob abe ian dan hal ed col fred /],
    ivy  => [qw/ ian col hal gav fred bob abe ed jon dan /],
    jan  => [qw/ ed hal gav abe bob jon col ian fred dan /],
  },
);

my %Engaged;
my %Proposed;

match_them();
check_stability();
perturb();
check_stability();

sub match_them {
    say 'Matchmaking:';
    while(my $man = unmatched_man()) {
        my $woman = preferred_choice($man);
        $Proposed{$man}{$woman} = 1;
        if(! $Engaged{W}{$woman}) {
            engage($man, $woman);
            say "\t$woman and $man";
        }
        else {
            if(woman_prefers($woman, $man)) {
                my $engaged_man = $Engaged{W}{$woman};
                engage($man, $woman);
                undef $Engaged{M}{$engaged_man};
                say "\t$woman dumped $engaged_man for $man";
            }
        }
    }
}

sub check_stability {
    say 'Stablility:';
    my $stable = 1;
    foreach my $m (men()) {
        foreach my $w (women()) {
            if(man_prefers($m, $w) && woman_prefers($w, $m)) {
                say "\t$w prefers $m to $Engaged{W}{$w} and $m prefers $w to $Engaged{M}{$m}";
                $stable = 0;
            }
        }
    }
    if($stable) {
        say "\t(all marriages stable)";
    }
}

sub unmatched_man {
    return first { ! $Engaged{M}{$_} } men();
}

sub preferred_choice {
    my $man = shift;
    return first { ! $Proposed{$man}{$_} } @{ $Likes{M}{$man} };
}

sub engage {
    my ($man, $woman) = @_;
    $Engaged{W}{$woman} = $man;
    $Engaged{M}{$man} = $woman;
}

sub prefers {
    my $sex = shift;
    return sub {
        my ($person, $prospect) = @_;

        my $choices = join ' ', @{ $Likes{$sex}{$person} };
        return index($choices, $prospect) < index($choices, $Engaged{$sex}{$person});
    }
}

BEGIN {
    *woman_prefers = prefers('W');
    *man_prefers   = prefers('M');
}

sub perturb {
    say 'Perturb:';
    say "\tengage abi with fred and bea with jon";
    engage('fred' => 'abi');
    engage('jon'  => 'bea');
}

sub men   { keys %{ $Likes{M} } }
sub women { keys %{ $Likes{W} } }

"Implement the Gale-Shapley algorithm to solve the Stable Marriage problem. The program takes as input the preferences of ten men and ten women, and outputs a stable set of engagements. It then perturbs this set to form an unstable set of engagements and checks this new set for stability."


sub a { print 'A'; return $_[0] }
sub b { print 'B'; return $_[0] }

# Test-driver
sub test {
    for my $op ('&&','||') {
        for (qw(1,1 1,0 0,1 0,0)) {
           my ($x,$y) = /(.),(.)/;
           print my $str = "a($x) $op b($y)", ': ';
           eval $str; print "\n"; } }
}

# Test and display
test();

The code defines two functions, 'a' and 'b', both of which take a boolean value as input, return the same value, and print their name when called. The code then calculates the values of two equations, 'x = a(i) and b(j)' and 'y = a(i) or b(j)', ensuring that function 'b' is only called when necessary, utilizing the concept of short-circuit evaluation. If the programming language does not support short-circuit evaluation, nested 'if' statements are used to achieve the same effect. The code is optimized for languages like Perl that use short-circuit boolean evaluation.


use Acme::AGMorse qw(SetMorseVals SendMorseMsg);
SetMorseVals(20,30,400);
SendMorseMsg('Hello World! abcdefg @\;');  # note, caps are ingnored in Morse Code
exit;

Acme::AGMorse
Audio::Beep
Switch

1) pcspkr may not be available by default. Run: sudo modprobe pcspkr
2) pcspkr may be available but muted.
    - Check your sound prefrences,usually a right click over the speaker icon

send a string as Morse code to an audio device, ignoring unknown characters or indicating them with a different pitch. Known issues exist on UNIX systems.


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

sub can_make_word {
    my ($word, @blocks) = @_;
    $_ = uc join q(), sort split // for @blocks;
    my %blocks;
    $blocks{$_}++ for @blocks;
    return _can_make_word(uc $word, %blocks)
}

sub _can_make_word {
    my ($word, %blocks) = @_;
    my $char = substr $word, 0, 1, q();

    my @candidates = grep 0 <= index($_, $char), keys %blocks;
    for my $candidate (@candidates) {
        next if $blocks{$candidate} <= 0;
        local $blocks{$candidate} = $blocks{$candidate} - 1;
        return 1 if q() eq $word or _can_make_word($word, %blocks);
    }
    return
}

use Test::More tests => 8;

my @blocks1 = qw(BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM);
is(can_make_word("A",       @blocks1), 1);
is(can_make_word("BARK",    @blocks1), 1);
is(can_make_word("BOOK",    @blocks1), undef);
is(can_make_word("TREAT",   @blocks1), 1);
is(can_make_word("COMMON",  @blocks1), undef);
is(can_make_word("SQUAD",   @blocks1), 1);
is(can_make_word("CONFUSE", @blocks1), 1);

my @blocks2 = qw(US TZ AO QA);
is(can_make_word('auto', @blocks2), 1);

Regex based alternate[edit]
#!/usr/bin/perl

use strict; # https://rosettacode.org/wiki/ABC_Problem
use warnings;

printf "%30s  %s\n", $_, can_make_word( $_,
  'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM' )
  for qw( A BARK BOOK TREAT COMMON SQUAD CONFUSE );

sub can_make_word
  {
  my ($word, $blocks) = @_;
  my $letter = chop $word or return 'True';
  can_make_word( $word, $` . $' ) eq 'True' and return 'True'
    while $blocks =~ /\w?$letter\w?/gi;
  return 'False';
  }

The code is a function that checks if a given word can be spelled using a specific collection of ABC blocks. Each block contains two letters and can only be used once. The function is case-insensitive and returns a boolean value indicating whether or not the word can be spelled with the provided blocks. The function is tested with seven different words.


Library: Digest::MD5MD5
use Digest::MD5 qw(md5_hex);

print md5_hex("The quick brown fox jumped over the lazy dog's back"), "\n";

use Digest::MD5;

$md5 = Digest::MD5->new;
$md5->add("The quick brown fox jumped over the lazy dog's back");
print $md5->hexdigest, "\n";

The code implements the MD5 algorithm to encode a string. It optionally validates the implementation using test values from IETF RFC 1321. However, due to MD5's known weaknesses, it suggests using stronger alternatives for production-grade cryptography. The code also provides an object-oriented implementation of the MD5 algorithm.


sorts a list of Object Identifiers (OIDs). An OID is a string of non-negative integers in base 10, separated by dots. The sorting is done lexicographically based on the dot-separated fields, using numeric comparison between fields. The codes can also sort the OIDs as "version strings", a Perl syntax where characters' codes are specified as a dot-delimited sequence of integers.


use Socket;

$host = gethostbyname('localhost');
$in = sockaddr_in(256, $host);
$proto = getprotobyname('tcp');
socket(Socket_Handle, AF_INET, SOCK_STREAM, $proto);
connect(Socket_Handle, $in);
send(Socket_Handle, 'hello socket world', 0, $in);
close(Socket_Handle);

use Socket::Class;

$sock = Socket::Class->new(
  'remote_port' => 256,
) || die Socket::Class->error;
$sock->send('hello socket world');
$sock->free;

Open a socket to localhost on port 256, send the message "hello socket world", and then close the socket in an object-oriented manner. Error handling is not implemented.


Using Net::SMTP[edit]

use Net::SMTP;
use Authen::SASL;
  # Net::SMTP's 'auth' method needs Authen::SASL to work, but
  # this is undocumented, and if you don't have the latter, the
  # method will just silently fail. Hence we explicitly use
  # Authen::SASL here.

sub send_email {
  my %o =
     (from => '', to => [], cc => [],
      subject => '', body => '',
      host => '', user => '', password => '',
      @_);
  ref $o{$_} or $o{$_} = [$o{$_}] foreach 'to', 'cc';

  my $smtp = Net::SMTP->new($o{host} ? $o{host} : ())
      or die "Couldn't connect to SMTP server";

  $o{password} and
     $smtp->auth($o{user}, $o{password}) ||
     die 'SMTP authentication failed';

  $smtp->mail($o{user});
  $smtp->recipient($_) foreach @{$o{to}}, @{$o{cc}};
  $smtp->data;
  $o{from} and $smtp->datasend("From: $o{from}\n");
  $smtp->datasend('To: ' . join(', ', @{$o{to}}) . "\n");
  @{$o{cc}} and $smtp->datasend('Cc: ' . join(', ', @{$o{cc}}) . "\n");
  $o{subject} and $smtp->datasend("Subject: $o{subject}\n");
  $smtp->datasend("\n$o{body}");
  $smtp->dataend;

  return 1;
}

send_email
   from => 'A. T. Tappman',
   to => ['suchandsuch@example.com', 'soandso@example.org'],
   cc => 'somebodyelse@example.net',
   subject => 'Important message',
   body => 'I yearn for you tragically.',
   host => 'smtp.example.com:587',
   user => 'tappman@example.com',
   password => 'yossarian';

send_email
   to => 'suchandsuch@example.com',
   user => 'tappman@example.com';

Using LWP[edit]

use strict;
use LWP::UserAgent;
use HTTP::Request;

sub send_email {
  my ($from, $to, $cc, $subject, $text) = @_;

  my $ua = LWP::UserAgent->new;
  my $req = HTTP::Request->new (POST => "mailto:$to",
                                [ From => $from,
                                  Cc => $cc,
                                  Subject => $subject ],
                                $text);
  my $resp = $ua->request($req);
  if (! $resp->is_success) {
    print $resp->status_line,"\n";
  }
}

send_email('from-me@example.com', 'to-foo@example.com', '',
           "very important subject",
           "Body text\n");

implement a function to send an email with parameters for From, To, Cc addresses, Subject, message text, server name and login details. The function throws an error if it fails to connect to the server or authenticate. It uses libraries or functions from the language and works on any platform that supports Perl. If the host parameter is omitted, it uses the SMTP_Hosts defined in Net::Config. It can also send email by a POST to a mailto: URL. The solution is portable across different operating systems.


use POSIX;
printf "%o\n", $_ for (0 .. POSIX::UINT_MAX);

use bigint;
my $i = 0;
printf "%o\n", $i++ while 1

#!/usr/bin/perl

$_ = 0;
s/([^7])?(7*)$/ $1 + 1 . $2 =~ tr!7!0!r /e while print "$_\n";

generate a sequential count in octal format, starting from zero and incrementing by one. Each number is printed on a separate line. The program continues until it is terminated or the maximum value of the numeric type in use is reached.


implement a generic swap function or operator that can exchange the values of two variables or storage places, regardless of their types. The function handles both statically and dynamically typed languages, with certain limitations for each. In statically typed languages, the function may require variables to have mutually compatible types. In dynamically typed languages, the function may struggle with destructively swapping two variables. The function may not support swapping in some functional languages or static languages lacking support for parametric polymorphism. Perl's built-in swap functionality is also mentioned.


palindrome uses the built-in function reverse().
palindrome_c uses iteration; it is a translation of the C solution.
palindrome_r uses recursion.
palindrome_e uses a recursive regular expression.

# Palindrome.pm
package Palindrome;

use strict;
use warnings;

use Exporter 'import';
our @EXPORT = qw(palindrome palindrome_c palindrome_r palindrome_e);

sub palindrome
{
    my $s = (@_ ? shift : $_);
    return $s eq reverse $s;
}

sub palindrome_c
{
    my $s = (@_ ? shift : $_);
    for my $i (0 .. length($s) >> 1)
    {
        return 0 unless substr($s, $i, 1) eq substr($s, -1 - $i, 1);
    }
    return 1;
}

sub palindrome_r
{
    my $s = (@_ ? shift : $_);
    if (length $s <= 1) { return 1; }
    elsif (substr($s, 0, 1) ne substr($s, -1, 1)) { return 0; }
    else { return palindrome_r(substr($s, 1, -1)); }
}

sub palindrome_e
{
    (@_ ? shift : $_) =~ /^(.?|(.)(?1)\2)$/ + 0
}

# pbench.pl
use strict;
use warnings;

use Benchmark qw(cmpthese);
use Palindrome;

printf("%d, %d, %d, %d: %s\n",
       palindrome, palindrome_c, palindrome_r, palindrome_e, $_)
for
    qw/a aa ab abba aBbA abca abba1 1abba
    ingirumimusnocteetconsumimurigni/,
    'ab cc ba',	'ab ccb a';

printf "\n";

my $latin = "ingirumimusnocteetconsumimurigni";
cmpthese(100_000, {
    palindrome => sub { palindrome $latin },
    palindrome_c => sub { palindrome_c $latin },
    palindrome_r => sub { palindrome_r $latin },
    palindrome_e => sub { palindrome_e $latin },
});

The code includes a function to check if a given sequence of characters forms a palindrome. It supports Unicode characters and has an additional function to detect inexact palindromes, ignoring white-space, punctuation, and case sensitivity. The functions take a parameter or default to $_ if no parameter is provided. The functions do not ignore case or strip characters, but this can be achieved by using a specific command before calling the functions. The code also includes an example of how to use the functions. The palindrome function is optimized for speed.


print $ENV{HOME}, "\n";

use POSIX 'getenv';
print getenv("HOME"),"\n";

demonstrate how to retrieve a specific environment variable from a process using the %ENV hash and the getenv() function from the POSIX module. The common environment variables available on Unix systems such as PATH, HOME, and USER are used as examples.


implement the Sudan function, a non-primitive recursive function, which calculates and returns the value of F(x, y) based on the defined rules.


Matrix[edit]
Translation of: Julia
function f = fib(n)

	f = [1 1 ; 1 0]^(n-1);
	f = f(1,1);

end
Iterative[edit]
function F = fibonacci(n)

    Fn = [1 0]; %Fn(1) is F_{n-2}, Fn(2) is F_{n-1}
    F = 0; %F is F_{n}

    for i = (1:abs(n))
        Fn(2) = F;
        F = sum(Fn);
        Fn(1) = Fn(2);
    end

    if n < 0
        F = F*((-1)^(n+1));
    end

end
Dramadah Matrix Method[edit]

function number = fibonacci2(n)

    if n == 1
        number = 1;
    elseif n == 0
        number = 0;
    elseif n < 0
        number = ((-1)^(n+1))*fibonacci2(-n);;
    else
        number = det(gallery('dramadah',n,3));
    end

end
Tartaglia/Pascal Triangle Method[edit]
function number = fibonacci(n)
%construct the Tartaglia/Pascal Triangle
    pt=tril(ones(n));
    for r = 3 : n
    % Every element is the addition of the two elements
    % on top of it. That means the previous row.
        for c = 2 : r-1
            pt(r, c) = pt(r-1, c-1) + pt(r-1, c);
        end
    end
    number=trace(rot90(pt));
end

implement a function to generate the nth Fibonacci number, either iteratively or recursively. The function also has the optional feature to support negative n values by using the inverse of the positive definition. Additionally, the codes utilize the method suggested by MATLAB help file, using the determinate of the Dramadah Matrix of type 3 and size n-by-n to generate the nth Fibonacci number.


function evens = selectEvenNumbers(list)

    evens = list( mod(list,2) == 0 );

end

select certain elements from an array into a new array in a generic way. Specifically, it selects all even numbers from an array. Optionally, it can also filter destructively by modifying the original array instead of creating a new one.


>> fliplr(['She told me that she spoke English and I said great. '...
'Grabbed her hand out the club and I said let''s skate.'])

ans =

.etaks s'tel dias I dna bulc eht tuo dnah reh debbarG .taerg dias I dna hsilgnE ekops ehs taht em dlot ehS

"Function to reverse a string, with additional functionality to preserve Unicode combining characters. Includes a test for the built-in 'fliplr()' function's handling of Unicode characters."


implement three methods to remove duplicate elements from an array: 1) using a hash table, 2) sorting the elements and removing consecutive duplicates, and 3) iterating through the list and discarding any repeated elements. It also mentions the use of MATLAB's built-in function "unique(list)" for this task, which only works for vectors.


function sortedArray = quickSort(array)

    if numel(array) <= 1 %If the array has 1 element then it can't be sorted
        sortedArray = array;
        return
    end

    pivot = array(end);
    array(end) = [];

    %Create two new arrays which contain the elements that are less than or
    %equal to the pivot called "less" and greater than the pivot called
    %"greater"
    less = array( array <= pivot );
    greater = array( array > pivot );

    %The sorted array is the concatenation of the sorted "less" array, the
    %pivot and the sorted "greater" array in that order
    sortedArray = [quickSort(less) pivot quickSort(greater)];

end

function sortedArray = quickSort(array)

    if numel(array) <= 1 %If the array has 1 element then it can't be sorted
        sortedArray = array;
        return
    end

    pivot = array(end);
    array(end) = [];

    sortedArray = [quickSort( array(array <= pivot) ) pivot quickSort( array(array > pivot) )];

end

quickSort([4,3,7,-2,9,1])

ans =

    -2     1     3     4     7     9

implement the Quicksort algorithm to sort an array or list. The algorithm selects a pivot element from the array and divides the rest of the elements into two partitions - one with elements less than the pivot and the other with elements greater than the pivot. It then recursively sorts these partitions and combines them with the pivot to get the sorted array. The codes also handle the selection of the pivot element and the allocation of new arrays or in-place sorting.


function pset = powerset(theSet)

    pset = cell(size(theSet)); %Preallocate memory

    %Generate all numbers from 0 to 2^(num elements of the set)-1
    for i = ( 0:(2^numel(theSet))-1 )

        %Convert i into binary, convert each digit in binary to a boolean
        %and store that array of booleans
        indicies = logical(bitget( i,(1:numel(theSet)) ));

        %Use the array of booleans to extract the members of the original
        %set, and store the set containing these members in the powerset
        pset(i+1) = {theSet(indicies)};

    end

end

powerset({{}})

ans =

     {}    {1x1 cell} %This is the same as { {},{{}} }

powerset({{1,2},3})

ans =

    {1x0 cell}    {1x1 cell}    {1x1 cell}    {1x2 cell} %This is the same as { {},{{1,2}},{3},{{1,2},3} }

The code defines a function that takes a set as input and outputs its power set. The power set includes all possible subsets of the input set, including the empty set and the set itself. The function can handle sets of any type of data structure, thanks to the use of cell arrays in MATLAB. It also demonstrates support for power sets of the empty set and the set containing only the empty set.


function [closest,closestpair] = closestPair(xP,yP)

    N = numel(xP);

    if(N <= 3)

        %Brute force closestpair
        if(N < 2)
            closest = +Inf;
            closestpair = {};
        else
            closest = norm(xP{1}-xP{2});
            closestpair = {xP{1},xP{2}};

            for i = ( 1:N-1 )
                for j = ( (i+1):N )
                    if ( norm(xP{i} - xP{j}) < closest )
                        closest = norm(xP{i}-xP{j});
                        closestpair = {xP{i},xP{j}};
                    end %if
                end %for
            end %for
        end %if (N < 2)
    else

        halfN = ceil(N/2);

        xL = { xP{1:halfN} };
        xR = { xP{halfN+1:N} };
        xm = xP{halfN}(1);

        %cellfun( @(p)le(p(1),xm),yP ) is the same as { p ∈ yP : px ≤ xm }
        yLIndicies = cellfun( @(p)le(p(1),xm),yP );

        yL = { yP{yLIndicies} };
        yR = { yP{~yLIndicies} };

        [dL,pairL] = closestPair(xL,yL);
        [dR,pairR] = closestPair(xR,yR);

        if dL < dR
            dmin = dL;
            pairMin = pairL;
        else
            dmin = dR;
            pairMin = pairR;
        end

        %cellfun( @(p)lt(norm(xm-p(1)),dmin),yP ) is the same as
        %{ p ∈ yP : |xm - px| < dmin }
        yS = {yP{ cellfun( @(p)lt(norm(xm-p(1)),dmin),yP ) }};
        nS = numel(yS);

        closest = dmin;
        closestpair = pairMin;

        for i = (1:nS-1)
            k = i+1;

            while( (k<=nS) && (yS{k}(2)-yS{i}(2) < dmin) )

                if norm(yS{k}-yS{i}) < closest
                    closest = norm(yS{k}-yS{i});
                    closestpair = {yS{k},yS{i}};
                end

                k = k+1;
            end %while
        end %for
    end %if (N <= 3)
end %closestPair

The code provides two functions to solve the Closest Pair of Points problem in a two-dimensional space. The first function uses a brute-force approach, iterating through each pair of points to find the pair with the smallest distance. The second function uses a divide and conquer approach, recursively dividing the set of points and finding the closest pair in each subset. The points are sorted by x and y coordinates for efficient comparison. The code also includes references for further reading.


function r=rot13(s)
    if ischar(s)
        r=s;  % preallocation and copy of non-letters
        for i=1:size(s,1)
            for j=1:size(s,2)
                if isletter(s(i,j))
                    if s(i,j)>=97   % lower case
                        base = 97;
                    else            % upper case
                        base = 65;
                    end
                    r(i,j)=char(mod(s(i,j)-base+13,26)+base);
                end
            end
        end
    else
        error('Argument must be a CHAR')
    end
end

>> rot13('Hello World!')

ans =

Uryyb Jbeyq!

function text = rot13(text)
    if ischar(text)

        selectedLetters = ( (text >= 'A') & (text <= 'Z') ); %Select upper case letters
        text(selectedLetters) = char( mod( text(selectedLetters)-'A'+13,26 )+'A' );

        selectedLetters = ( (text >= 'a') & (text <= 'z') ); %Select lower case letters
        text(selectedLetters) = char( mod( text(selectedLetters)-'a'+13,26 )+'a' );

    else
        error('Argument must be a string.')
    end
end

>> plainText = char((64:123))

plainText =

@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{

>> rot13(plainText)

ans =

@NOPQRSTUVWXYZABCDEFGHIJKLM[\]^_`nopqrstuvwxyzabcdefghijklm{

implement a rot-13 encoding function that can be optionally wrapped in a utility program. This function replaces every ASCII alphabet letter with the letter that is 13 characters away from it in the 26 letter alphabet, wrapping from z to a as needed. The function should work on both upper and lower case letters, preserve case, and pass all non-alphabetic characters without alteration. The function can be used to obfuscate text to prevent casual reading of spoilers or offensive material.


function result = halveInt(number)

    result = idivide(number,2,'floor');

end

function result = doubleInt(number)

    result = times(2,number);

end

%Returns a logical 1 if the number is even, 0 otherwise.
function trueFalse = isEven(number)

    trueFalse = logical( mod(number,2)==0 );

end

function answer = ethiopianMultiplication(multiplicand,multiplier)

    %Generate columns
    while multiplicand(end)>1
        multiplicand(end+1,1) = halveInt( multiplicand(end) );
        multiplier(end+1,1) = doubleInt( multiplier(end) );
    end

    %Strike out appropriate rows
    multiplier( isEven(multiplicand) ) = [];

    %Generate answer
    answer = sum(multiplier);

end

ethiopianMultiplication( int32(17),int32(34) )

ans =

   578

The code defines four functions for Ethiopian multiplication. The first function halves an integer, the second function doubles an integer, and the third function checks if an integer is even. These functions are used in the fourth function, which performs Ethiopian multiplication. The multiplication function works by repeatedly halving the first number and doubling the second number, discarding rows where the first number is even, and then summing the remaining values in the second column to get the product of the original two numbers.


Built-in[edit]

answer = factorial(N)
Recursive[edit]
function f=fac(n)
    if n==0
        f=1;
        return
    else
        f=n*fac(n-1);
    end
Iterative[edit]

  function b=factorial(a)
	b=1;
	for i=1:a
	    b=b*i;
	end

implement a function to calculate the factorial of a given number. The function can be either iterative or recursive. It optionally includes error handling for negative input values. The function is similar to the built-in factorial function in MATLAB, but without the precision limitations for numbers greater than 21.


function BullsAndCows
% Plays the game Bulls and Cows as the "game master"

    % Create a secret number
    nDigits = 4;
    lowVal = 1;
    highVal = 9;
    digitList = lowVal:highVal;
    secret = zeros(1, 4);
    for k = 1:nDigits
        idx = randi(length(digitList));
        secret(k) = digitList(idx);
        digitList(idx) = [];
    end

    % Give game information
    fprintf('Welcome to Bulls and Cows!\n')
    fprintf('Try to guess the %d-digit number (no repeated digits).\n', nDigits)
    fprintf('Digits are between %d and %d (inclusive).\n', lowVal, highVal)
    fprintf('Score: 1 Bull per correct digit in correct place.\n')
    fprintf('       1 Cow per correct digit in incorrect place.\n')
    fprintf('The number has been chosen. Now it''s your moooooove!\n')
    gs = input('Guess: ', 's');

    % Loop until user guesses right or quits (no guess)
    nGuesses = 1;
    while gs
        gn = str2double(gs);
        if isnan(gn) || length(gn) > 1  % Not a scalar
            fprintf('Malformed guess. Keep to valid scalars.\n')
            gs = input('Try again: ', 's');
        else
            g = sprintf('%d', gn) - '0';
            if length(g) ~= nDigits || any(g < lowVal) || any(g > highVal) || ...
                    length(unique(g)) ~= nDigits    % Invalid number for game
                fprintf('Malformed guess. Remember:\n')
                fprintf('  %d digits\n', nDigits)
                fprintf('  Between %d and %d inclusive\n', lowVal, highVal)
                fprintf('  No repeated digits\n')
                gs = input('Try again: ', 's');
            else
                score = CountBullsCows(g, secret);
                if score(1) == nDigits
                    fprintf('You win! Bully for you! Only %d guesses.\n', nGuesses)
                    gs = '';
                else
                    fprintf('Score: %d Bulls, %d Cows\n', score)
                    gs = input('Guess: ', 's');
                end
            end
        end
        nGuesses = nGuesses+1;  % Counts malformed guesses
    end
end

function score = CountBullsCows(guess, correct)
% Checks the guessed array of digits against the correct array to find the score
% Assumes arrays of same length and valid numbers
    bulls = guess == correct;
    cows = ismember(guess(~bulls), correct);
    score = [sum(bulls) sum(cows)];
end

generate a unique four-digit number, accept and validate user guesses, calculate and print scores based on matching digits and their positions, and end the program when the user guess matches the generated number.


    mu = 1; sd = 0.5;
    x = randn(1000,1) * sd + mu;

   x = normrnd(mu, sd, [1000,1]);

function randNum = randNorm(mu0,chi2, sz)

    radiusSquared = +Inf;

    while (radiusSquared >= 1)
        u = ( 2 * rand(sz) ) - 1;
        v = ( 2 * rand(sz) ) - 1;

        radiusSquared = u.^2 + v.^2;
    end

    scaleFactor = sqrt( ( -2*log(radiusSquared) )./ radiusSquared );
    randNum = (v .* scaleFactor .* chi2) + mu0;

end

>> randNorm(1,.5, [1000,1])

ans =

   0.693984121077029

generate a collection of 1000 normally distributed pseudo-random numbers with a mean of 1.0 and a standard deviation of 0.5. If only uniformly distributed random numbers can be generated, transformation algorithms like Box-Mueller Transform are used. The statistics toolbox function is also utilized in the process.


A = [1 3 -5]
B = [4 -2 -1]
C = dot(A,B)

function C = DotPro(A,B)
  C = sum( A.*B );
end

Implement a function to compute the dot product of two vectors of arbitrary length. The vectors should be of the same length, and the function should multiply corresponding terms from each vector and sum the products to produce the result. The function can also handle vector products.


docNode = com.mathworks.xml.XMLUtils.createDocument('root');
docRootNode = docNode.getDocumentElement;
thisElement = docNode.createElement('element');
thisElement.appendChild(docNode.createTextNode('Some text here'));
docRootNode.appendChild(thisElement);

 xmlwrite(docNode)

ans =

<?xml version="1.0" encoding="utf-8"?>
<root>
   <element>Some text here</element>
</root>

Create a simple DOM and serialize it into the specified XML format.


"Code to draw a graphical or ASCII art representation of a sphere, with options for static or rotational projection."


function s = nth(n)
    tens = mod(n, 100);
    if tens > 9 && tens < 20
        suf = 'th';
    else
        switch mod(n, 10)
            case 1
                suf = 'st';
            case 2
                suf = 'nd';
            case 3
                suf = 'rd';
            otherwise
                suf = 'th';
        end
    end
    s = sprintf('%d%s', n, suf);
end

The code defines a function that takes an integer input greater than or equal to zero and returns a string representation of the number with an ordinal suffix. The function is tested with ranges 0 to 25, 250 to 265, and 1000 to 1025. The use of apostrophes in the output is optional.


number = ceil(10*rand(1));
[guess, status] = str2num(input('Guess a number between 1 and 10: ','s'));

while (~status || guess ~= number)
    [guess, status] = str2num(input('Guess again: ','s'));
end
disp('Well guessed!')

"Implement a number guessing game where the computer selects a number between 1 and 10. The player is repeatedly prompted to guess the number until the correct number is guessed, upon which a 'Well guessed!' message is displayed and the program terminates. A conditional loop is used to facilitate repeated guessing."


function passed = luhn(num)
if nargin == 0 % evaluate test cases
  testnum = [49927398716 49927398717 1234567812345678 1234567812345670];
  for num = testnum
    disp([int2str(num) ': ' int2str(luhn(num))])
  end
  return
end
% luhn function starts here
d = int2str(num) - '0';	% convert number into vector of digits
m = [2:2:8,1:2:9];	% rule 3: maps 1:9 to [2 4 6 8 1 3 5 7 9]
passed = ~mod(sum(d(end:-2:1)) + sum(m(d(end-1:-2:1))), 10);
end

The code implements the Luhn test for validating credit card numbers. It first reverses the order of the digits in the number, then sums every other odd digit to form a partial sum s1. For every other even digit, it multiplies each by two and sums the digits if the result is greater than nine to form partial sums for the even digits, and then sums these to form s2. If the sum of s1 and s2 ends in zero, the number is a valid credit card number. The code validates the numbers 49927398716, 49927398717, 1234567812345678, and 1234567812345670 using this method.


function [indAlive] = josephus(numPeople,count)
% Josephus: Given a circle of numPeople individuals, with a count of count,
% find the index (starting at 1) of the survivor [see Josephus Problem]

%% Definitions:
%   0 = dead position
%   1 = alive position
%   index = # of person

%% Setting up
arrPeople = ones(1, numPeople);
currInd = 0;

%% Counting
while (length(arrPeople(arrPeople == 1)) > 1)     % While more than 1 person is alive
    counter = 0;
    while counter ~= count                       % Counting until we hit the count
        currInd = currInd + 1;                  % Move to the next person

        if currInd > numPeople                  % If overflow, wraparound
            currInd = currInd - numPeople;
        end

        if arrPeople(currInd)                   % If the current person is alive
            counter = counter + 1;                % Add 1 person to the count
            %fprintf("Index: %d \t| Counter: %d\n", currInd, counter)           % Uncomment to display index and counter location
        end

    end

    arrPeople(currInd) = 0;                     % Kill the person we reached
    %fprintf("Killed person %d \n", currInd)                                   % Uncomment to display order of killing
    %disp(arrPeople)                                                           % Uncomment to display current status of people
end

indAlive = find(arrPeople);

end

- Determine the final survivor in the Josephus problem given any number of prisoners (n) and a step count (k).
- Calculate the position of any prisoner in the killing sequence.
- Provide an option to save a certain number of prisoners (m).
- The numbering of prisoners can start from either 0 or 1.
- The complexity of the solution is O(kn) for the complete killing sequence and O(m) for finding the m-th prisoner to die.


function towerOfHanoi(n,A,C,B)
    if (n~=0)
        towerOfHanoi(n-1,A,B,C);
        disp(sprintf('Move plate %d from tower %d to tower %d',[n A C]));
        towerOfHanoi(n-1,B,C,A);
    end
end

Sample output:
towerOfHanoi(3,1,3,2)
Move plate 1 from tower 1 to tower 3
Move plate 2 from tower 1 to tower 2
Move plate 1 from tower 3 to tower 2
Move plate 3 from tower 1 to tower 3
Move plate 1 from tower 2 to tower 1
Move plate 2 from tower 2 to tower 3
Move plate 1 from tower 1 to tower 3

Implement a recursive solution for the Towers of Hanoi problem, based on the Python example provided in the Wikipedia entry for the Tower of Hanoi puzzle.


function [grayImage] = colortograyscale(inputImage)
   grayImage = rgb2gray(inputImage);

extend the data storage type to support grayscale images, define operations to convert color images to grayscale and vice versa using the specified formulas, and ensure no rounding errors cause run-time problems or distorted results when storing calculated luminance as an unsigned integer.


Character Length[edit]
>> length('møøse')

ans =

     5
Byte Length[edit]

>> numel(dec2hex('møøse'))

ans =

    10

The code calculates the character and byte length of a string, considering different encodings like UTF-8 and UTF-16. It handles Unicode code points correctly, distinguishing between actual character counts and code unit counts. It also provides the string length in graphemes if possible. The code works properly with strings encoded in UTF-16, like MATLAB does.


function solution = sudokuSolver(sudokuGrid)

    %Define what each of the sub-boxes of the sudoku grid are by defining
    %the start and end coordinates of each sub-box. The indecies represent
    %the column and row of a grid coordinate on the actual sudoku grid.
    %The contents of each cell with the same grid coordinates contain the
    %information to determine which sub-box that grid coordinate is
    %contained in on the sudoku grid. The array in position 1, i.e.
    %subBoxes{row,column}(1), represents the row indecies of the subbox.
    %The array in position 2, i.e. subBoxes{row,column}(2),represents the
    %column indecies of the subbox.

    subBoxes(1:9,1:9) = {{(1:3),(1:3)}};
    subBoxes(4:6,:)= {{(4:6),(1:3)}};
    subBoxes(7:9,:)= {{(7:9),(1:3)}};

    for column = (4:6)
        for row = (1:9)
            subBoxes{row,column}(2)= {4:6};
        end
    end
    for column = (7:9)
        for row = (1:9)
            subBoxes{row,column}(2)= {7:9};
        end
    end

    %Generate a cell of arrays which contain the possible values of the
    %sudoku grid for each cell in the grid. The possible values a specific
    %grid coordinate can take share the same indices as the sudoku grid
    %coordinate they represent.
    %For example sudokuGrid(m,n) can be possibly filled in by the
    %values stored in the array at possibleValues(m,n).
    possibleValues(1:9,1:9) = { (1:9) };

    %Filter the possibleValues so that no entry exists for coordinates that
    %have already been filled in. This will replace any array with an empty
    %array in the possibleValues cell matrix at the coordinates of a grid
    %already filled in the sudoku grid.
    possibleValues( ~isnan(sudokuGrid) )={[]};

    %Iterate through each grid coordinate and filter out the possible
    %values for that grid point that aren't alowed by the rules given the
    %current values that are filled in. Or, if there is only one possible
    %value for the current coordinate, fill it in.

    solution = sudokuGrid; %so the original sudoku input isn't modified
    memory = 0; %contains the previous iterations possibleValues
    dontStop = true; %stops the while loop when nothing else can be reasoned about the sudoku

    while( dontStop )

%% Process of elimination deduction method

        while( ~isequal(possibleValues,memory) ) %Stops using the process of elimination deduction method when this deduction rule stops working

            memory = possibleValues; %Copies the current possibleValues into memory, for the above conditional on the next iteration.

            %Iterate through everything
            for row = (1:9)
                for column = (1:9)

                    if isnan( solution(row,column) ) %If grid coordinate hasn't been filled in, try to determine it's value.

                        %Look at column to see what values have already
                        %been filled in and thus the current grid
                        %coordinate can't be
                        removableValues = solution( ~isnan(solution(:,column)),column );

                        %If there are any values that have been assigned to
                        %other cells in the same column, filter those out
                        %of the current cell's possiblValues
                        if ~isempty(removableValues)
                            for m = ( 1:numel(removableValues) )
                                possibleValues{row,column}( possibleValues{row,column}==removableValues(m) )=[];
                            end
                        end

                        %If the current grid coordinate can only atain one
                        %possible value, assign it that value
                        if numel( possibleValues{row,column} ) == 1
                            solution(row,column) = possibleValues{row,column};
                            possibleValues(row,column)={[]};
                        end
                    end  %end if

                    if isnan( solution(row,column) ) %If grid coordinate hasn't been filled in, try to determine it's value.

                        %Look at row to see what values have already
                        %been filled in and thus the current grid
                        %coordinate can't be
                        removableValues = solution( row,~isnan(solution(row,:)) );

                        %If there are any values that have been assigned to
                        %other cells in the same row, filter those out
                        %of the current cell's possiblValues
                        if ~isempty(removableValues)
                            for m = ( 1:numel(removableValues) )
                                possibleValues{row,column}( possibleValues{row,column}==removableValues(m) )=[];
                            end
                        end

                        %If the current grid coordinate can only atain one
                        %possible value, assign it that value
                        if numel( possibleValues{row,column} ) == 1
                            solution(row,column) = possibleValues{row,column};
                            possibleValues(row,column)={[]};
                        end
                    end %end if

                    if isnan( solution(row,column) ) %If grid coordinate hasn't been filled in, try to determine it's value.

                        %Look at sub-box to see if any possible values can be
                        %filtered out. First pull the boundaries of the sub-box
                        %containing the current array coordinate
                        currentBoxBoundaries=subBoxes{row,column};

                        %Then pull the sub-boxes values out of the solution
                        box = solution(currentBoxBoundaries{:});

                        %Look at sub-box to see what values have already
                        %been filled in and thus the current grid
                        %coordinate can't be
                        removableValues = box( ~isnan(box) );

                        %If there are any values that have been assigned to
                        %other cells in the same sub-box, filter those out
                        %of the current cell's possiblValues
                        if ~isempty(removableValues)
                            for m = ( 1:numel(removableValues) )
                                possibleValues{row,column}( possibleValues{row,column}==removableValues(m) )=[];
                            end
                        end

                        %If the current grid coordinate can only atain one
                        %possible value, assign it that value
                        if numel( possibleValues{row,column} ) == 1
                            solution(row,column) = possibleValues{row,column};
                            possibleValues(row,column)={[]};
                        end
                    end %end if

                end %end for column
            end %end for row
        end %stop process of elimination

%% Check that there are no contradictions in the solved grid coordinates.

        %Check that each row at most contains one of each of the integers
        %from 1 to 9
        if ~isempty( find( histc( solution,(1:9),1 )>1 ) )
            solution = false;
            return
        end

        %Check that each column at most contains one of each of the integers
        %from 1 to 9
        if ~isempty( find( histc( solution,(1:9),2 )>1 ) )
            solution = false;
            return
        end

        %Check that each sub-box at most contains one of each of the integers
        %from 1 to 9
        subBoxBins = zeros(9,9);
        counter = 0;
        for row = [2 5 8]
            for column = [2 5 8]
                counter = counter +1;

                %because the sub-boxes are extracted as square matricies,
                %we need to reshape them into row vectors so all of the
                %boxes can be input into histc simultaneously
                subBoxBins(counter,:) = reshape( solution(subBoxes{row,column}{:}),1,9 );
            end
        end
        if ~isempty( find( histc( subBoxBins,(1:9),2 )>1 ) )
            solution = false;
            return
        end

        %Check to make sure there are no grid coordinates that are not
        %filled in and have no possible values.

        [rowStack,columnStack] = find(isnan(solution)); %extracts the indicies of the unsolved grid coordinates
        if (numel(rowStack) > 0)

            for counter = (1:numel(rowStack))
                if isempty(possibleValues{rowStack(counter),columnStack(counter)})
                    solution = false;
                    return
                end
            end

        %if there are no more grid coordinates to be filed in then the
        %sudoku is solved and we can return the solution without further
        %computation
        elseif (numel(rowStack) == 0)
            return
        end

%% Use the unique relative compliment of sets deduction method

        %Because no more information can be determined by the process of
        %ellimination we have to try a new method of reasoning. Now we will
        %look at the possible values a cell can take. If there is a value that
        %that grid coordinate can take but no other coordinates in the same row,
        %column or sub-box can take that value then we assign that coordinate
        %that value.

        keepGoing = true; %signals to keep applying rules to the current grid-coordinate because it hasn't been solved using previous rules
        dontStop = false; %if this method doesn't figure anything out, this will terminate the top level while loop

        [rowStack,columnStack] = find(isnan(solution)); %This will also take care of the case where the sudoku is solved
        counter = 0; %makes sure the loop terminates when there are no more cells to consider

        while( keepGoing && (counter < numel(rowStack)) ) %stop this method of reasoning when the value of one of the cells has been determined and return to the process of elimination method

            counter = counter + 1;

            row = rowStack(counter);
            column = columnStack(counter);

            gridPossibles = [possibleValues{row,column}];

            coords = (1:9);
            coords(column) = [];
            rowPossibles = [possibleValues{row,coords}]; %extract possible values for everything in the same row except the current grid coordinate

            totalMatches = zeros( numel(gridPossibles),1 ); %preallocate for speed

            %count how many times a possible value for the current cell
            %appears as a possible value for the cells in the same row
            for n = ( 1:numel(gridPossibles) )
                totalMatches(n) = sum( (rowPossibles == gridPossibles(n)) );
            end

            %remove any possible values for the current cell that have
            %matches in other cells
            gridPossibles = gridPossibles(totalMatches==0);

            %if there is only one possible value that the current cell can
            %take that aren't shared by other cells, assign that value to
            %the current cell.
            if numel(gridPossibles) == 1

                solution(row,column) = gridPossibles;
                possibleValues(row,column)={[]};
                keepGoing = false; %stop this method of deduction and return to the process of elimination
                dontStop = true; %keep the top level loop going

            end

            if(keepGoing) %do the same as above but for the current cell's column

                gridPossibles = [possibleValues{row,column}];

                coords = (1:9);
                coords(row) = [];
                columnPossibles = [possibleValues{coords,column}];

                totalMatches = zeros( numel(gridPossibles),1 );
                for n = ( 1:numel(gridPossibles) )
                    totalMatches(n) = sum( (columnPossibles == gridPossibles(n)) );
                end

                gridPossibles = gridPossibles(totalMatches==0);

                if numel(gridPossibles) == 1

                    solution(row,column) = gridPossibles;
                    possibleValues(row,column)={[]};
                    keepGoing = false;
                    dontStop = true;

                end
            end

            if(keepGoing) %do the same as above but for the current cell's sub-box

                gridPossibles = [possibleValues{row,column}];

                currentBoxBoundaries = subBoxes{row,column};
                subBoxPossibles = [];
                for m = currentBoxBoundaries{1}
                    for n = currentBoxBoundaries{2}
                        if ~((m == row) && (n == column))
                            subBoxPossibles = [subBoxPossibles possibleValues{m,n}];
                        end
                    end
                end

                totalMatches = zeros( numel(gridPossibles),1 );
                for n = ( 1:numel(gridPossibles) )
                    totalMatches(n) = sum( (subBoxPossibles == gridPossibles(n)) );
                end

                gridPossibles = gridPossibles(totalMatches==0);

                if numel(gridPossibles) == 1

                    solution(row,column) = gridPossibles;
                    possibleValues(row,column)={[]};
                    keepGoing = false;
                    dontStop = true;

                end
            end %end

        end %end  set comliment rule while loop
    end %end top-level while loop

%% Depth-first search of the solution tree

    %There is no more reasoning that can solve the puzzle so now it is time
    %for a depth-first search of the possible answers, basically
    %guess-and-check. This is implimented recursively.

    [rowStack,columnStack] = find(isnan(solution)); %Get all of the unsolved cells

    if (numel(rowStack) > 0) %If all of the above stuff terminates then there will be at least one grid coordinate not filled in

        %Treat the rowStack and columnStack like stacks, and pop the top
        %value off the stack to act as the current node whose
        %possibleValues to search through, then assign the possible values
        %of that grid coordinate to a variable that holds that values to
        %search through
        searchTreeNodes = possibleValues{rowStack(1),columnStack(1)};

        keepSearching = true; %used to continue the search
        counter = 0; %counts the amount of possible values searched for the current node
        tempSolution = solution; %used so that the solution is not overriden until a solution hase been found

        while( keepSearching && (counter < numel(searchTreeNodes)) ) %stop recursing if we run out of possible values for the current node

            counter = counter + 1;
            tempSolution(rowStack(1),columnStack(1)) = searchTreeNodes(counter); %assign a possible value to the current node in the tree
            tempSolution = sudokuSolver(tempSolution); %recursively call the solver with the current guess value for the current grid coordinate

            if ~islogical(tempSolution) %if tempSolution is not a boolean but a valid sudoku stop recursing and set solution to tempSolution
               keepSearching = false;
               solution = tempSolution;
            elseif counter == numel(searchTreeNodes) %if we have run out of guesses for the current node, stop recursing and return a value of "false" for the solution
               solution = false;
            else %reset tempSolution to the current state of the board and try the next guess for the possible value of the current cell
               tempSolution = solution;
            end

        end %end recursion
    end  %end if

%% End of program
end %end sudokuSolver

sudoku = [NaN   NaN   NaN   NaN     8     3     9   NaN   NaN
     1   NaN   NaN   NaN   NaN   NaN   NaN     3   NaN
   NaN   NaN     4   NaN   NaN   NaN   NaN     7   NaN
   NaN     4     2   NaN     3   NaN   NaN   NaN   NaN
     6   NaN   NaN   NaN   NaN   NaN   NaN   NaN     4
   NaN   NaN   NaN   NaN     7   NaN   NaN     1   NaN
   NaN     2   NaN   NaN   NaN   NaN   NaN   NaN   NaN
   NaN     8   NaN   NaN   NaN     9     2   NaN   NaN
   NaN   NaN   NaN     2     5   NaN   NaN   NaN     6]

solution =

     7     6     5     4     8     3     9     2     1
     1     9     8     7     2     6     4     3     5
     2     3     4     9     1     5     6     7     8
     8     4     2     5     3     1     7     6     9
     6     1     7     8     9     2     3     5     4
     3     5     9     6     7     4     8     1     2
     9     2     6     1     4     7     5     8     3
     5     8     1     3     6     9     2     4     7
     4     7     3     2     5     8     1     9     6

implement a Sudoku solver that uses a recursive, depth-first search to fill in a partially completed 9x9 Sudoku grid. The solver prunes the search tree using logical deduction rules. It can solve complex puzzles in about a minute. The code is structured in blocks that could be refactored into separate functions or a Sudoku class for improved readability and efficiency. The code should be saved in a file named "sudokuSolver.m". It takes a grid with empty cells represented as NaN as input and outputs the solved Sudoku in a human-readable format.