diff options
| author | Lubos Kolouch <lubos@kolouch.net> | 2019-07-26 12:48:01 +0200 |
|---|---|---|
| committer | Lubos Kolouch <lubos@kolouch.net> | 2019-07-26 12:48:01 +0200 |
| commit | a4c5b39677d5d58c1800accb8c55284c9b3318be (patch) | |
| tree | a8d9f6de5e1a896e261d30e225c4240fc2e8d519 | |
| parent | 972593266b5b30fc95df77e307420200d1a61c6e (diff) | |
| download | perlweeklychallenge-club-a4c5b39677d5d58c1800accb8c55284c9b3318be.tar.gz perlweeklychallenge-club-a4c5b39677d5d58c1800accb8c55284c9b3318be.tar.bz2 perlweeklychallenge-club-a4c5b39677d5d58c1800accb8c55284c9b3318be.zip | |
Challenge 018 LK
| -rw-r--r-- | challenge-018/lubos-kolouch/perl5/ch-1.pl | 117 | ||||
| -rw-r--r-- | challenge-018/lubos-kolouch/perl5/ch-2.pl | 115 |
2 files changed, 232 insertions, 0 deletions
diff --git a/challenge-018/lubos-kolouch/perl5/ch-1.pl b/challenge-018/lubos-kolouch/perl5/ch-1.pl new file mode 100644 index 0000000000..fef4d9155e --- /dev/null +++ b/challenge-018/lubos-kolouch/perl5/ch-1.pl @@ -0,0 +1,117 @@ +#!/usr/bin/perl +#=============================================================================== +# +# FILE: ch-1.pl +# +# USAGE: ./ch-1.pl +# +# DESCRIPTION: Task #1 +# +# Write a script that takes 2 or more strings as command line parameters and print the longest common substring. For example, the longest common substring of the strings “ABABC”, “BABCA” and “ABCBA” is string “ABC” of length 3. Other common substrings are “A”, “AB”, “B”, “BA”, “BC” and “C”. Please check this wiki page for details. +# +# +# OPTIONS: --- +# REQUIREMENTS: --- +# BUGS: --- +# NOTES: --- +# AUTHOR: Lubos Kolouch, +# ORGANIZATION: +# VERSION: 1.0 +# CREATED: 07/24/2019 08:48:27 PM +# REVISION: --- +#=============================================================================== + +use strict; +use warnings; +use feature qw{ say }; +use Data::Dumper; + +my %all_strings; +my $max_count = 0; + +# ignore substrings +my $seen_first; + +sub insert_to_all_strings { + my $str = shift; + + my %seen_str; + + my $length = length($str); + + for my $pos ( 0 .. $length - 1 ) { + for my $length_remain ( 1 .. $length - $pos ) { + my $sub_string = substr( $str, $pos, $length_remain ); + + # skip if this substring is not present in the first word + next if $seen_first and not defined $all_strings{length($sub_string)}{$sub_string}; + + # skip if the string was already present in the current letter + next if $seen_str{$sub_string}; + + # remember we have already seen the letter + $seen_str{$sub_string} = 1; + + my $current_count = $all_strings{$sub_string} // 0; + $current_count++; + + # We have seen the substring one more time + $max_count = $current_count if $current_count > $max_count; + + # Let us remember it + $all_strings{ length($sub_string) }{$sub_string}++; + } + + } + + $seen_first = 1; + + return 1; +} + +sub longest_str { + my @strings = @_; + + my $found_solution; + + # fill in all the common strings and their count + insert_to_all_strings($_) for (@strings); + + # print the longest one + + foreach my $str_length ( sort { $b <=> $a } keys %all_strings ) { + + foreach my $string ( keys %{ $all_strings{$str_length} } ) { + if ( $all_strings{$str_length}{$string} == scalar @strings ) { + + # we found a substring that is in all strings + say "Common string $string"; + $found_solution = $string; + } + } + + last if $found_solution; + } + + say 'No common string found' unless $found_solution; + return $found_solution; + +} + +###### MAIN ###### + +my @strings = @ARGV or die 'Usage: script string1 string2 stringN'; +die 'Usage: script string1 string2 stringN' unless @strings >= 2; + +longest_str(@strings); + +###### TESTS ###### + +use Test::More; + +say 'TESTS:'; +%all_strings = (); +$seen_first = 0; +is( longest_str( 'ABABC', 'BABCA', 'ABCBA' ), 'ABC', 'Test 1' ); + +done_testing; diff --git a/challenge-018/lubos-kolouch/perl5/ch-2.pl b/challenge-018/lubos-kolouch/perl5/ch-2.pl new file mode 100644 index 0000000000..5a3dd95865 --- /dev/null +++ b/challenge-018/lubos-kolouch/perl5/ch-2.pl @@ -0,0 +1,115 @@ +#!/usr/bin/perl +#=============================================================================== +# +# FILE: ch-2.pl +# +# USAGE: ./ch-2.pl +# +# DESCRIPTION: Task #2 +# +# +# Write a script to implement Priority Queue. It is like regular queue except each element has a priority associated with it. In a priority queue, an element with high priority is served before an element with low priority. Please check this wiki page for more informations. It should serve the following operations: +# +# 1) is_empty: check whether the queue has no elements. +# +# 2) insert_with_priority: add an element to the queue with an associated priority. +# +# 3) pull_highest_priority_element: remove the element from the queue that has the highest priority, and return it. If two elements have the same priority, then return element added first. +# +# +# OPTIONS: --- +# REQUIREMENTS: --- +# BUGS: --- +# NOTES: --- +# AUTHOR: Lubos Kolouch, +# ORGANIZATION: +# VERSION: 1.0 +# CREATED: 07/24/2019 08:48:27 PM +# REVISION: --- +#=============================================================================== + +use strict; +use warnings; +use feature qw{ say }; + +sub is_empty { + my $hash_ref = shift; + + return %{$hash_ref} ? 0 : 1; + +} + +sub insert_with_priority { + my ( $hash_ref, $priority, $element ) = @_; + + my %queue = %{$hash_ref}; + + push @{ $queue{$priority} }, $element; + + return %queue; +} + +sub pull_highest_priority_element { + my $hash_ref = shift; + + foreach my $priority ( sort { $b <=> $a } keys %$hash_ref ) { + + my $element = shift @{ %${hash_ref}{$priority} }; + + # destroy the queue if not neede + + delete $$hash_ref{$priority} unless scalar @{ %${hash_ref}{$priority} }; + + return $element; + } + + return 1; +} + +###### MAIN ###### + +###### TESTS ###### + +use Test::More; + +say 'TESTS:'; +my %empty; +my %not_empty = ( '1' => 'a' ); + +is( is_empty( \%empty ), 1, 'Testing empty queue' ); +is( is_empty( \%not_empty ), 0, 'Testing not empty queue' ); + +my %queue = insert_with_priority( \%empty, '1', 'aaa' ); + +is( $queue{1}[0], 'aaa', 'Testing added string equal to aaa' ); +isnt( $queue{1}[0], 'aab', 'Testing added string not equal to bbb' ); + +is( pull_highest_priority_element( \%queue ), 'aaa', 'is highest priority aaa' ); +is( is_empty( \%queue ), 1, 'is the queue empty now' ); + +%queue = insert_with_priority( \%queue, '2', 'aaa' ); +is( $queue{2}[0], 'aaa', 'Insert priority 2 element aaa' ); + +%queue = insert_with_priority( \%queue, '3', 'bbb' ); +is( $queue{2}[0], 'aaa', 'Is still priority 2 element aaa' ); +is( $queue{3}[0], 'bbb', 'Insert priority 3 element bbb' ); + +%queue = insert_with_priority( \%queue, '1', 'xxx' ); +is( $queue{2}[0], 'aaa', 'Is still priority 2 element aaa' ); +is( $queue{3}[0], 'bbb', 'Is still priority 3 element bbb' ); +is( $queue{1}[0], 'xxx', 'Is still priority 1 element xxx' ); +isnt( $queue{1}[0], 'aaa', 'Is priority 1 element not aaa' ); + +%queue = insert_with_priority( \%queue, '3', 'ccc' ); +is( $queue{2}[0], 'aaa', 'Is still priority 2 element aaa' ); +is( $queue{3}[0], 'bbb', 'Is still priority 3 element bbb' ); +is( $queue{1}[0], 'xxx', 'Is still priority 1 element xxx' ); +is( $queue{3}[1], 'ccc', 'Is now second priority 3 element ccc' ); + +is( pull_highest_priority_element( \%queue ), 'bbb', 'bbb correctly pulled' ); +is( pull_highest_priority_element( \%queue ), 'ccc', 'ccc correctly pulled' ); +is( pull_highest_priority_element( \%queue ), 'aaa', 'aaa correctly pulled' ); +is( pull_highest_priority_element( \%queue ), 'xxx', 'xxx correctly pulled' ); + +is( is_empty( \%queue ), 1, 'is the queue empty now' ); +done_testing; |
