From 1a5c129647a0800f2526a3cc86d5d947e15e88df Mon Sep 17 00:00:00 2001 From: PerlMonk Athanasius Date: Sun, 7 Jul 2019 07:15:54 -0700 Subject: Perl 5 & 6 solutions to Tasks 1, 2, and 3 of Challenge #015 Changes to be committed: new file: challenge-015/athanasius/perl5/ch-1.pl new file: challenge-015/athanasius/perl5/ch-2.pl new file: challenge-015/athanasius/perl5/ch-3.pl new file: challenge-015/athanasius/perl6/ch-1.p6 new file: challenge-015/athanasius/perl6/ch-2.p6 new file: challenge-015/athanasius/perl6/ch-3.p6 --- challenge-015/athanasius/perl5/ch-1.pl | 72 +++++++++++++ challenge-015/athanasius/perl5/ch-2.pl | 192 +++++++++++++++++++++++++++++++++ challenge-015/athanasius/perl5/ch-3.pl | 124 +++++++++++++++++++++ challenge-015/athanasius/perl6/ch-1.p6 | 74 +++++++++++++ challenge-015/athanasius/perl6/ch-2.p6 | 166 ++++++++++++++++++++++++++++ challenge-015/athanasius/perl6/ch-3.p6 | 93 ++++++++++++++++ 6 files changed, 721 insertions(+) create mode 100644 challenge-015/athanasius/perl5/ch-1.pl create mode 100644 challenge-015/athanasius/perl5/ch-2.pl create mode 100644 challenge-015/athanasius/perl5/ch-3.pl create mode 100644 challenge-015/athanasius/perl6/ch-1.p6 create mode 100644 challenge-015/athanasius/perl6/ch-2.p6 create mode 100644 challenge-015/athanasius/perl6/ch-3.p6 diff --git a/challenge-015/athanasius/perl5/ch-1.pl b/challenge-015/athanasius/perl5/ch-1.pl new file mode 100644 index 0000000000..ff550c4732 --- /dev/null +++ b/challenge-015/athanasius/perl5/ch-1.pl @@ -0,0 +1,72 @@ +#!perl + +################################################################################ +=comment + +Perl Weekly Challenge 015 +========================= + +Task #1 +------- + +Write a script to generate first 10 strong and weak prime numbers. + + For example, the nth prime number is represented by p(n). + + p(1) = 1 + p(2) = 3 + p(3) = 5 + + Strong Prime number p(n) when p(n) > [ p(n-1) + p(n+1) ] / 2 + Weak Prime number p(n) when p(n) < [ p(n-1) + p(n+1) ] / 2 + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2019 PerlMonk Athanasius # +#--------------------------------------# + +use strict; +use warnings; +use Const::Fast; +use Math::Prime::Util qw( prime_iterator ); + +const my $SERIES_LENGTH => 10; + +$| = 1; + +MAIN: +{ + my %primes = map { $_ => [] } qw( strong weak ); + my $iterator = prime_iterator(); + my $previous = $iterator->(); + my $current = $iterator->(); + + while (scalar $primes{strong}->@* < $SERIES_LENGTH || + scalar $primes{weak }->@* < $SERIES_LENGTH) + { + my $next = $iterator->(); + my $mean = ($previous + $next) / 2; + my $type = ($current > $mean) ? 'strong' : + ($current < $mean) ? 'weak' : 'balanced'; + + if ($type ne 'balanced' && scalar $primes{$type}->@* < $SERIES_LENGTH) + { + push $primes{$type}->@*, $current; + } + + ($previous, $current) = ($current, $next); + } + + print "\n"; + + for my $type (qw( strong weak )) + { + printf "The first %d %-*s primes are: %s\n", + $SERIES_LENGTH, length('strong'), $type, + join(', ', map { sprintf '%2d', $_ } $primes{$type}->@*); + } +} + +################################################################################ diff --git a/challenge-015/athanasius/perl5/ch-2.pl b/challenge-015/athanasius/perl5/ch-2.pl new file mode 100644 index 0000000000..286aaaa36f --- /dev/null +++ b/challenge-015/athanasius/perl5/ch-2.pl @@ -0,0 +1,192 @@ +#!perl + +################################################################################ +=comment + +Perl Weekly Challenge 015 +========================= + +Task #2 +------- + +Write a script to implement Vigenère cipher. The script should be able encode +and decode. Checkout wiki [ https://en.wikipedia.org/wiki/Vigen%C3%A8re_cipher +|page] for more information. + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2019 PerlMonk Athanasius # +#--------------------------------------# + +use strict; +use utf8; +use warnings; +use Const::Fast; +use Getopt::Long; +use POSIX qw( ceil ); + +# The alphabet for both plaintext and ciphertext: characters must have +# consecutive ordinal values within their character set + +# (1) The canonical alphabet: upper case only +const my @ALPHABET => ('A' .. 'Z'); + +# (2) Extended alphabet: allows messages and keys to be written in "CamelCase" +#const my @ALPHABET => ('A' .. 'Z', '[', '\\', ']', '^', '_', '`', 'a' .. 'z'); + +# (3) Full ASCII alphabet +#const my @ALPHABET => map { chr $_ } 32 .. 126; + +# Ordinal value of the first character in the alphabet + +const my $ORD_BASE => ord $ALPHABET[0]; + +# Regular expression to match non-alphabet characters (the first is captured) + +const my $NON_ALPHA => eval "qr{ ( [^$ALPHABET[0]-$ALPHABET[-1]] ) }x"; + +# Default values (from the Wikipedia page) + +const my $KEY => 'LEMON'; +const my $PLAINTEXT => 'ATTACKATDAWN'; + +# Usage message + +const my $USAGE => "\nUSAGE: perl $0 [--key ] [--plain|message ] " . + "[--cipher ]\n"; +$| = 1; + +MAIN: +{ + my ($key, $plaintext, $ciphertext) = read_command_line(); + + if (( $plaintext && $ciphertext) || + (!$plaintext && !$ciphertext)) + { + $plaintext //= $PLAINTEXT; # Allow empty string + my $cipher = encode($plaintext, $key); + my $decoded = decode($cipher, $key); + + printf "\nWith key '%s', '%s' --> '%s' --> '%s': %s\n", + $key, $plaintext, $cipher, $decoded, + $decoded eq $plaintext ? 'Success' : 'Failure'; + } + elsif ($plaintext) # Encode only + { + printf "\nWith key '%s', '%s' encodes to '%s'\n", + $key, $plaintext, encode($plaintext, $key); + } + else # Decode only + { + printf "\nWith key '%s', '%s' decodes to '%s'\n", + $key, $ciphertext, decode($ciphertext, $key); + } +} + +sub read_command_line +{ + my ($help, $key, $plaintext, $ciphertext); + + GetOptions + ( + 'help' => \$help, + 'key:s' => \$key, + 'plain|message:s' => \$plaintext, + 'cipher:s' => \$ciphertext, + + ) or die $USAGE; + + die $USAGE if $help; + + $key ||= $KEY; # Disallow empty string + + return ($key, $plaintext, $ciphertext); +} + +#------------------------------------------------------------------------------- +=Wikipedia article "Vigenère cipher" + +Vigenère can also be described algebraically. If the letters A–Z are taken to be +the numbers 0–25 ( A ≙ 0, B ≙ 1, etc.), and addition is performed modulo 26, +Vigenère encryption E using the key K can be written as + + C_i = E_K(M_i) = (M_i + K_i) mod 26 + +and decryption D using the key K as + + M_i = D_K(C_i) = (C_i - K_i) mod 26, + +in which M = M_1 ... M_n is the message, + C = C_1 ... C_n is the ciphertext and + K = K_1 ... K_n is the key obtained by repeating the keyword ⌈n/m⌉ + times in which m is the keyword length. +=cut +#------------------------------------------------------------------------------- + +sub encode +{ + my ($plaintext, $key) = @_; + + validate('plaintext', $plaintext, $key); + + my @plain = str2num($plaintext); + my @key = (str2num($key)) x ceil(length($plaintext) / length($key)); + my @cipher; + + while (@plain) + { + my $m = shift @plain; + my $k = shift @key; + + push @cipher, ($m + $k) % scalar @ALPHABET; + } + + return num2str(@cipher); +} + +sub decode +{ + my ($ciphertext, $key) = @_; + + validate('ciphertext', $ciphertext, $key); + + my @cipher = str2num($ciphertext); + my @key = (str2num($key)) x ceil(length($ciphertext) / length($key)); + my @plain; + + while (@cipher) + { + my $c = shift @cipher; + my $k = shift @key; + + push @plain, ($c - $k) % scalar @ALPHABET; + } + + return num2str(@plain); +} + +sub validate +{ + my ($name, $text, $key) = @_; + + die "Invalid character '$1' in $name\n" if $text =~ $NON_ALPHA; + die "Invalid character '$1' in key\n" if $key =~ $NON_ALPHA; +} + +sub str2num +{ + my ($string) = @_; + + return map { ord($_) - $ORD_BASE } split //, $string; +} + +sub num2str +{ + my @nums = @_; + + return join '', map { chr( $_ + $ORD_BASE ) } @nums; +} + +################################################################################ diff --git a/challenge-015/athanasius/perl5/ch-3.pl b/challenge-015/athanasius/perl5/ch-3.pl new file mode 100644 index 0000000000..1672fa5c2d --- /dev/null +++ b/challenge-015/athanasius/perl5/ch-3.pl @@ -0,0 +1,124 @@ +#!perl + +################################################################################ +=comment + +Perl Weekly Challenge 015 +========================= + +Task #3 +------- + +Write a script to use Language Detection API. For more information about API, +please visit [ https://detectlanguage.com/ |page]. The API task is *optional* +but we would love to see your solution. + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2019 PerlMonk Athanasius # +#--------------------------------------# + +use strict; +use warnings; +use Const::Fast; +use Getopt::Long; +use JSON; +use LWP::UserAgent (); + +const my $API_KEY => '< redacted >'; +const my $MAX_TEXT => 66; # Max text length for 80-char console +const my $TIMEOUT => 30; # seconds +const my $URL_DETECT => 'https://ws.detectlanguage.com/0.2/detect'; +const my $URL_LANGS => 'https://ws.detectlanguage.com/0.2/languages'; +const my $USAGE => "USAGE: perl $0 --help | --text | " . + "--file \n"; + +$| = 1; + +MAIN: +{ + print "\n"; + + my $text = read_text(); + my $response = get_lang_detection($text); + my $json = JSON->new; + my $lang_det = $json->decode($response)->{data}{detections}[0]; + my $confidence = $lang_det->{confidence} // 'Unknown'; + my $reliable = $lang_det->{isReliable} ? 'Yes' : 'No'; + my $lang_code = $lang_det->{language} // 'Unknown'; + + printf "Text: %s\n", substr($text, 0, $MAX_TEXT); + printf "Language: %s = %s\n", $lang_code, get_lang_name($lang_code); + print "Is reliable: $reliable\n"; + print "Confidence: $confidence\n"; +} + +sub read_text +{ + my ($help, $text, $file); + + GetOptions + ( + 'help' => \$help, + 'text:s' => \$text, + 'file:s' => \$file, + + ) or die $USAGE; + + die $USAGE if $help || ($text && $file) || (!$text && !$file); + + if ($file) + { + open my $fh, '<', $file + or die "Cannot open file '$file' for reading, stopped"; + + local $/; # Slurp + $text = <$fh>; + + close $fh + or die "Cannot close file '$file', stopped"; + } + + return ($text); +} + +sub get_lang_detection +{ + my ($text) = @_; + my $ua = LWP::UserAgent->new(timeout => $TIMEOUT); + $ua->default_header('Authorization' => "Bearer $API_KEY"); + my $response = $ua->post($URL_DETECT, Content => "q=$text"); + +{ + use Data::Dump; + dd $response; +} + $response->is_success + or die $response->status_line . ', stopped'; + + return $response->decoded_content; +} + +sub get_lang_name +{ + my ($lang_code) = @_; + + return 'Unknown' if $lang_code eq 'Unknown'; + + my $ua = LWP::UserAgent->new(timeout => $TIMEOUT); + my $response = $ua->get($URL_LANGS); + + $response->is_success + or die $response->status_line . ', stopped'; + + my $content = $response->decoded_content; + my $json = JSON->new; + my $languages = $json->decode($content); + my %languages = map { $_->{code} => $_->{name} } @$languages; + + return $languages{$lang_code}; +} + +################################################################################ diff --git a/challenge-015/athanasius/perl6/ch-1.p6 b/challenge-015/athanasius/perl6/ch-1.p6 new file mode 100644 index 0000000000..6bdaa18650 --- /dev/null +++ b/challenge-015/athanasius/perl6/ch-1.p6 @@ -0,0 +1,74 @@ +use v6; + +################################################################################ +=begin comment + +Perl Weekly Challenge 015 +========================= + +Task #1 +------- + +Write a script to generate first 10 strong and weak prime numbers. + + For example, the nth prime number is represented by p(n). + + p(1) = 1 + p(2) = 3 + p(3) = 5 + + Strong Prime number p(n) when p(n) > [ p(n-1) + p(n+1) ] / 2 + Weak Prime number p(n) when p(n) < [ p(n-1) + p(n+1) ] / 2 + +=end comment +################################################################################ + +#--------------------------------------# +# Copyright © 2019 PerlMonk Athanasius # +#--------------------------------------# + +my UInt constant $SERIES-LENGTH = 10; +my constant @PRIME-TYPES = < strong weak >; +my UInt constant $TYPE-LENGTH = @PRIME-TYPES.map( { .chars } ).max; + +sub MAIN() +{ + my %primes = @PRIME-TYPES.map: { $_ => [] }; + my UInt $previous = next-prime; + my UInt $current = next-prime; + + while %primes{'strong'}.elems < $SERIES-LENGTH || + %primes{'weak' }.elems < $SERIES-LENGTH + { + my Int $next = next-prime; + my Rat $mean = ($previous + $next) / 2; + my Str $type = ($current > $mean) ?? 'strong' !! + ($current < $mean) ?? 'weak' !! 'balanced'; + + if $type ∈ @PRIME-TYPES && %primes{$type}.elems < $SERIES-LENGTH + { + %primes{$type}.push: $current; + } + + ($previous, $current) = ($current, $next); + } + + say ''; + say "The first $SERIES-LENGTH ", $_.fmt( "%-{ $TYPE-LENGTH }s" ), + ' primes are: ', %primes{$_}.map({ .fmt( '%2d' ) }).join(', ') + for @PRIME-TYPES; +} + +sub next-prime(--> UInt) +{ + state UInt $p = 1; + + repeat until $p.is-prime + { + ++$p; + } + + return $p; +} + +################################################################################ diff --git a/challenge-015/athanasius/perl6/ch-2.p6 b/challenge-015/athanasius/perl6/ch-2.p6 new file mode 100644 index 0000000000..51f109a534 --- /dev/null +++ b/challenge-015/athanasius/perl6/ch-2.p6 @@ -0,0 +1,166 @@ +use v6; + +################################################################################ +=begin comment + +Perl Weekly Challenge 015 +========================= + +Task #2 +------- + +Write a script to implement Vigenère cipher. The script should be able encode +and decode. Checkout wiki [ https://en.wikipedia.org/wiki/Vigen%C3%A8re_cipher +|page] for more information. + +=end comment +################################################################################ + +#--------------------------------------# +# Copyright © 2019 PerlMonk Athanasius # +#--------------------------------------# + +use MONKEY-SEE-NO-EVAL; + +# The alphabet for both plaintext and ciphertext: characters must have +# consecutive ordinal values within their character set + +# (1) The canonical alphabet: upper case only +my constant @ALPHABET = ('A' .. 'Z'); + +# (2) Extended alphabet: allows messages and keys to be written in "CamelCase" +#my constant @ALPHABET = ('A' .. 'Z', '[', '\\', ']', '^', '_', '`', 'a' .. 'z'); + +# (3) Full ASCII alphabet +#my constant @ALPHABET = (32 .. 126).map: { chr $_ }; + +# Ordinal value of the first character in the alphabet + +my UInt constant $ORD-BASE = ord @ALPHABET[0]; + +# Regular expression to match non-alphabet characters (the first is captured) + +my constant $NON-ALPHA = EVAL 'rx/ ( <-[' ~ @ALPHABET.join('') ~ ']> ) /'; + +# Default values (from the Wikipedia page) + +my Str constant $KEY = 'LEMON'; +my Str constant $PLAINTEXT = 'ATTACKATDAWN'; + +sub MAIN +( + Bool :$help, #= this usage message + Str :$key = $KEY, #= key to encode and/or decode + Str :message(:$plain), #= plaintext to be encoded + Str :$cipher, #= ciphertext to be decoded +) +{ + die 'Empty key' unless $key; + + if ($help) + { + say "\n$*USAGE"; + } + elsif (( $plain && $cipher) || + (!$plain && !$cipher)) + { + my $plaintext = $plain // $PLAINTEXT; # Allow empty string + my $ciphertext = encode($plaintext, $key); + my $decodedtext = decode($ciphertext, $key); + + say "\nWith key '$key', '$plaintext' --> '$ciphertext' --> ", + "'$decodedtext': ", + $decodedtext eq $plaintext ?? 'Success' !! 'Failure'; + } + elsif ($plain) # Encode only + { + say "\nWith key '$key', '$plain' encodes to ", + "'{ encode($plain, $key) }'"; + } + else # Decode only + { + say "\nWith key '$key', '$cipher' decodes to ", + "'{ decode($cipher, $key) }'"; + } +} + +#------------------------------------------------------------------------------- +=begin wp + +From the Wikipedia article "Vigenère cipher": + +Vigenère can also be described algebraically. If the letters A–Z are taken to be +the numbers 0–25 ( A ≙ 0, B ≙ 1, etc.), and addition is performed modulo 26, +Vigenère encryption E using the key K can be written as + + C_i = E_K(M_i) = (M_i + K_i) mod 26 + +and decryption D using the key K as + + M_i = D_K(C_i) = (C_i - K_i) mod 26, + +in which M = M_1 ... M_n is the message, + C = C_1 ... C_n is the ciphertext and + K = K_1 ... K_n is the key obtained by repeating the keyword ⌈n/m⌉ + times in which m is the keyword length. + +=end wp +#------------------------------------------------------------------------------- + +sub encode(Str:D $plaintext, Str:D $key) +{ + validate('plaintext', $plaintext, $key); + + my @plain = str2num($plaintext); + my UInt $mult = ceiling($plaintext.chars / $key.chars); + my @key = (str2num($key) xx $mult)[*;*]; # Flatten the list + my @cipher; + + while @plain + { + my $m = @plain.shift; + my $k = @key.shift; + + @cipher.push: ($m + $k) % @ALPHABET.elems; + } + + return num2str(@cipher); +} + +sub decode(Str:D $ciphertext, Str:D $key) +{ + validate('ciphertext', $ciphertext, $key); + + my @cipher = str2num($ciphertext); + my UInt $mult = ceiling($ciphertext.chars / $key.chars); + my @key = (str2num($key) xx $mult)[*;*]; # Flatten the list + my @plain; + + while @cipher + { + my $c = @cipher.shift; + my $k = @key.shift; + + @plain.push: ($c - $k) % @ALPHABET.elems; + } + + return num2str(@plain); +} + +sub validate(Str:D $name, Str:D $text, Str:D $key) +{ + die "Invalid character '$0' in $name\n" if $text ~~ $NON-ALPHA; + die "Invalid character '$0' in key\n" if $key ~~ $NON-ALPHA; +} + +sub str2num(Str:D $string) +{ + return $string.split('', :skip-empty).map: { ord($_) - $ORD-BASE }; +} + +sub num2str(@nums) +{ + return @nums.map( { chr( $_ + $ORD-BASE ) } ).join(''); +} + +################################################################################ diff --git a/challenge-015/athanasius/perl6/ch-3.p6 b/challenge-015/athanasius/perl6/ch-3.p6 new file mode 100644 index 0000000000..aa0bda8db0 --- /dev/null +++ b/challenge-015/athanasius/perl6/ch-3.p6 @@ -0,0 +1,93 @@ +use v6; + +################################################################################ +=begin comment + +Perl Weekly Challenge 015 +========================= + +Task #3 +------- + +Write a script to use Language Detection API. For more information about API, +please visit [ https://detectlanguage.com/ |page]. The API task is *optional* +but we would love to see your solution. + +=end comment +################################################################################ + +#--------------------------------------# +# Copyright © 2019 PerlMonk Athanasius # +#--------------------------------------# + +use JSON::Tiny; +use LWP::UserAgent:from (); + +my Str constant $API-KEY = '< redacted >'; +my UInt constant $MAX-TEXT = 66; # max text length for 80-char console +my UInt constant $TIMEOUT = 30; # seconds +my Str constant $URL-DETECT = 'https://ws.detectlanguage.com/0.2/detect'; +my Str constant $URL-LANGS = 'https://ws.detectlanguage.com/0.2/languages'; + +sub MAIN +( + Bool :$help, #= this usage message + Str :$text, #= text with language to be detected + Str :$file, #= name of file containing text with language to be detected +) +{ + say ''; + die $*USAGE if $help || ($text && $file) || (!$text && !$file); + + my utf8 $target = $file ?? $file.IO.slurp.encode('UTF-8') + !! $text.encode('UTF-8'); + my Str $response = get-lang-detection($target); + my %lang-det = from-json($response){'data'}{'detections'}[0]; + my Rat $confidence = %lang-det{'confidence'} // 'Unknown'; + my Str $reliable = %lang-det{'isReliable'} ?? 'Yes' !! 'No'; + my Str $lang-code = %lang-det{'language'} // 'Unknown'; + + say 'Text: ', $target.decode.substr(0, $MAX-TEXT); + say 'Language: ', $lang-code, ' = ', get-lang-name($lang-code); + say 'Is reliable: ', $reliable; + say 'Confidence: ', $confidence; + + CATCH + { + default + { + .payload.say; + } + }; +} + +sub get-lang-detection(utf8:D $text --> Str) +{ + my $ua = LWP::UserAgent.new(timeout => $TIMEOUT); + $ua.default_header('Authorization' => "Bearer $API-KEY"); + my $response = $ua.post($URL-DETECT, Content => "q=$text"); + + $response.is_success + or die $response.status_line ~ ', stopped'; + + return $response.decoded_content; +} + +sub get-lang-name(Str:D $lang-code --> Str) +{ + return 'Unknown' if $lang-code eq 'Unknown'; + + my $ua = LWP::UserAgent.new(timeout => $TIMEOUT); + my $response = $ua.get($URL-LANGS); + + $response.is_success + or die $response.status_line ~ ', stopped'; + + my $content = $response.decoded_content; + my $languages = from-json($content); + my %languages = $languages.map: { $_{'code'} => $_{'name'} }; + + return %languages{$lang-code}; +} + +################################################################################ -- cgit