diff options
| -rw-r--r-- | challenge-046/saiftynet/Perl/ch-1.pl | 118 | ||||
| -rw-r--r-- | challenge-046/saiftynet/Perl/ch-2.pl | 47 |
2 files changed, 165 insertions, 0 deletions
diff --git a/challenge-046/saiftynet/Perl/ch-1.pl b/challenge-046/saiftynet/Perl/ch-1.pl new file mode 100644 index 0000000000..eb245eafa5 --- /dev/null +++ b/challenge-046/saiftynet/Perl/ch-1.pl @@ -0,0 +1,118 @@ +#!/usr/env/perl + +# TASK #1 Cryptic Message +# The communication system of an office is broken and message received +# are not completely reliable. Write a script to decrypt the provided +# repeated message (one message repeated 6 times). +# HINT: Look for characters repeated in a particular position +# in all six messages received. + +# The broken messager replaces some characters of the message +# with other characters. By repeatedly using the messager, we can +# collect the most frequent characters at a given position and thereby +# deal with the broken-ness. Multiple sampling reduces errors. +# We can simulate such a messenger and test it + +use strict;use warnings; +use Time::HiRes qw{sleep}; + +my $messages1=[ 'H x l 4 !', + 'c e - l o', + 'z e 6 l g', + 'H W l v R', + 'q 9 m # o' ]; + +my $messages2=[ 'P + 2 l ! a t o ', + '1 e 8 0 R $ 4 u ', + '5 - r ] + a > / ', + 'P x w l b 3 k \ ', + '2 e 3 5 R 8 y u ', + '< ! r ^ ( ) k 0 ' ]; + +print "First set results :-",collector($messages1),"\n"; +print "Second set results :-",collector($messages2),"\n"; + +# This solution extends the Task by creating a simulated broken messager +# and tests the decrypter by repeated sampling until stable. + +print "\nTesting decoding of broken messages. A message is sent repeatedly, +responses collected and attempt is made to decode based on available +results. This continues until the results are stable. This does not +always work of course. Randomness is such...\n\n"; + +tryUntilStable("Hi there matey!"); + + +# The routine that works on a collection of mangled messages and returns +# the most common characters for each position in the messages + +sub collector{ + my $messages=shift; # the list ref of messages + my $result=""; # the result to return + + foreach my $col (0.. length $$messages[0]){ # for each poition + my %collection=(); # hash to store frequencies + foreach my $message (@$messages){ + no warnings; # so that undef === 0 + $collection{(split //,$message)[$col]}++; # increment count when found + } + my $max=0; my $commonest=""; # now search and find commonest + foreach my $char (keys %collection){ + if ($collection{$char} > $max) { + $max=$collection{$char}; + $commonest=$char; + } + } + $result.=$commonest; # add the commonenst char to our result + } + return $result; +} + +# simulates a broken messager. The characters in the message are +# sent correctly or replaced by a random character. How broken the +# messager is can be set by altering $brokenness + +sub brokenMessager{ + my $message=shift; + + my $brokenness=0.4; # likelihood of mangling + + my $allChars=""; # a string of all printable chars + $allChars .= chr for 1..255; # First get all characters 0 to 255, + $allChars =~s/[^!-~]//g; # Then remove anything non printable + + my $result=""; + + foreach my $char (split //,$message){ # split $message and random replace + $result.=(rand()>$brokenness)?(split //,$allChars)[rand()*length $allChars]:$char; + } + return $result; + +} + +# Keep sending a message through the broken messager, and collect +# results. Then test using collector(). When the result no longer +# changes we imagine that enough data has been collected to give a +# correct guess. This is not always true of course... + +sub tryUntilStable{ + my $message=shift; + my $tests=[]; + my $result=""; my $guess="A guess"; + while ($result ne $guess){ + $result=$guess; + my $messageReceived=brokenMessager($message); + print $messageReceived,"\n"; + sleep 0.5; + push @$tests,$messageReceived; + $guess=collector($tests); + } + + print "\nFinal result:- $result\n" + + +} + + + + diff --git a/challenge-046/saiftynet/Perl/ch-2.pl b/challenge-046/saiftynet/Perl/ch-2.pl new file mode 100644 index 0000000000..1e43fbb1b2 --- /dev/null +++ b/challenge-046/saiftynet/Perl/ch-2.pl @@ -0,0 +1,47 @@ +#!/usr/env/perl + +# TASK #2 Is the room open? +# There are 500 rooms in a hotel with 500 employees having keys to all +# the rooms. The first employee opened main entrance door of all the +# rooms. The second employee then closed the doors of room numbers +# 2,4,6,8,10 and so on to 500. The third employee then closed the door +# if it was opened or opened the door if it was closed of rooms +# 3,6,9,12,15 and so on to 500. Similarly the fourth employee did the +# same as the third but only room numbers 4,8,12,16 and so on to 500. +# This goes on until all employees has had a turn. +# Write a script to find out all the rooms still open at the end. + +# An array holds the state of each door +# As array are indexed from zero, but as there is no door zero, +# we create an array of $doornCount+1 doors, and ignore door[0] +# A shut door is represented as 0, and an open door being not 0. + +use strict;use warnings; + +my $doorCount=500; + +my @doors=(0)x($doorCount+1); # $doorCount+1 doors + +foreach my $doorman (1..$#doors) { # each of the employees + my $n=1; # multiples starting with one + while ($doorman*$n<=($doorCount)){ # and continuing until no more doors + # toggles the door state (using 'not') + $doors[$doorman*$n++]=not $doors[$doorman*$n]; + } +} + +# print each open door; +foreach my $door (1..$#doors){ + print " ".$door if $doors[$door]; +} + +print "\n"; +# The results are interesting. The door will only stay open if it has an +# odd number of factors. Factors of a number generally occur as pairs +# that multiply together to produce that number...so the only way to get a +# odd number of factors is when it possible for both the factors to be +# the same...i.e the number has to be a square number. +# the same results can therefore be obtained by: + +my $cheat=1; +print " ".($cheat++)**2 while $cheat<sqrt($doorCount); |