RabbitFarm
2025-07-13
Let’s Count All of Our Nice Strings
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Counter Integers
You are given a string containing only lower case English letters and digits. Write a script to replace every non-digit character with a space and then return all the distinct integers left.
The code can be contained in a single file which has the following structure. The different code sections are explained in detail later.
We don’t really need to do the replacement with spaces since we could just use a regex to get the numbers or even just iterate over the string character by character. Still though, in the spirit of fun we’ll do it anyway.
Ok, sure, now we have a string with spaces and numbers. Now we have to use a regex (maybe with split, or maybe not) or loop over the string anyway to get the numbers. But we could have just done that from the beginning!Well, let’s force ourselves to do something which makes use of our converted string. We are going to write the new string with spaces and numbers to a PNG image file. Later we are going to OCR the results.
The image will be 500x500 and be black text on a white background for ease of character recognition. This fixed size is fine for the examples, more complex examples would require dynamic sizing of the image. The font choice is somewhat arbitrary, although intuitively a fixed width font like Courier should be easier to OCR.
The file paths used here are for my system, MacOS 15.4.
-
sub write_image{
my($s) = @_;
my $width = 500;
my $height = 500;
my $image_file = q#/tmp/output_image.png#;
my $image = GD::Image->new($width, $height);
my $white = $image->colorAllocate(255, 255, 255);
my $black = $image->colorAllocate(0, 0, 0);
$image->filledRectangle(0, 0, $width - 1, $height - 1, $white);
my $font_path = q#/System/Library/Fonts/Courier.ttc#;
my $font_size = 14;
$image->stringFT($black, $font_path, $font_size, 0, 10, 50, $s);
open TEMP, q/>/, qq/$image_file/;
binmode TEMP;
print TEMP $image->png;
close TEMP;
return $image_file;
}
◇
This second subroutine will handle the OCRing of the image. It’ll also be the main subroutine we call which produces the final result.
After experimenting with tesseract and other open source OCR options it seemed far easier to make use of a hosted service. OCR::OcrSpace is a module ready made for interacting with OcrSpace, an OCR solution provider that offers a free tier of service suitable for our needs. Registration is required in order to obtain an API key.
-
sub counter_integers{
my($s) = @_;
my @numbers;
my $image = write_image($s);
my $ocrspace = OCR::OcrSpace->new();
my $ocrspace_parameters = { file => qq/$image/,
apikey => q/XXXXXXX/,
filetype => q/PNG/,
scale => q/True/,
isOverlayRequired => q/True/,
OCREngine => 2};
my $result = $ocrspace->get_result($ocrspace_parameters);
$result = decode_json($result);
my $lines = $result->{ParsedResults}[0]
->{TextOverlay}
->{Lines};
for my $line (@{$lines}){
for my $word (@{$line->{Words}}){
push @numbers, $word->{WordText};
}
}
return join q/, /, @numbers;
}
◇
Just to make sure things work as expected we’ll define a few short tests.
-
MAIN:{
print counter_integers q/the1weekly2challenge2/;
print qq/\n/;
print counter_integers q/go21od1lu5c7k/;
print qq/\n/;
print counter_integers q/4p3e2r1l/;
print qq/\n/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 1, 2, 2 21, 1, 5, 7 4, 3, 2, 1
Part 2: Nice String
You are given a string made up of lower and upper case English letters only. Write a script to return the longest substring of the give string which is nice. A string is nice if, for every letter of the alphabet that the string contains, it appears both in uppercase and lowercase.
We’ll do this in two subroutines: one for confirming if a substring is nice, and another for generating substrings.
This subroutine examines each letter and sets a hash value for both upper and lower case versions of the letter as they are seen. We return true if all letters have both an upper and lower case version.
-
sub is_nice{
my ($s) = @_;
my %seen;
for my $c (split //, $s){
if($c =~ m/[a-z]/) {
$seen{$c}{lower} = 1;
}
elsif($c =~ m/[A-Z]/) {
$seen{lc($c)}{upper} = 1;
}
}
for my $c (keys %seen){
return 0 unless exists $seen{$c}{lower} &&
exists $seen{$c}{upper};
}
return 1;
}
◇
-
Fragment referenced in 6.
Here we just generate all substrings in a nested loop.
-
sub nice_substring{
my ($s) = @_;
my $n = length($s);
my $longest = q//;
for my $i (0 .. $n - 1) {
for my $j ($i + 1 .. $n) {
my $substring = substr($s, $i, $j - $i);
if (is_nice($substring) &&
length($substring) > length($longest)){
$longest = $substring;
}
}
}
return $longest;
}
◇
-
Fragment referenced in 6.
The main section is just some basic tests.
-
MAIN:{
say nice_substring q/YaaAho/;
say nice_substring q/cC/;
say nice_substring q/A/;
}
◇
-
Fragment referenced in 6.
Sample Run
$ perl perl/ch-2.pl Weekly abc
References
posted at: 16:54 by: Adam Russell | path: /perl | permanent link to this entry
2025-07-09
The Weekly Challenge 328 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Replace all ?
You are given a string containing only lower case English letters and ?. Write a script to replace all ? in the given string so that the string doesn’t contain consecutive repeating characters.
Our solution is short and will be contained in a single file that has the following structure.
Let’s use a DCG! First we’ll define a couple of helper rules to track the state of the replacement as the string gets processed.
-
replacement(Replacement), [Replacement] --> [Replacement].
replacement(R, Replacement), [Replacement] --> [R].
◇
-
Fragment referenced in 1.
Next let’s have the DCG rules themselves. This looks a little more complex then it could be just because I handle certain corner cases as separate rules. Basically all we’re doing is looking at the current character code of the string to see if it’s a question mark (63) and if it is then check the previous character and the next character and rely on backtracking to find a suitable random letter. The corner cases are for when we have no previous character and if we just have one character remaining to process. We also consider the case when we have a character other than ?.
-
replace(Input) --> replacement(R, Replacement),
{\+ R == [],
Input = [C, CNext|T],
C == 63,
random(97, 123, C0),
last(R, CPrevious),
\+ C0 == CPrevious,
\+ C0 == CNext,
append(R, [C0], Replacement)
},
replace([CNext|T]).
replace(Input) --> replacement(R, Replacement),
{R == [],
Input = [C, CNext|T],
C == 63,
random(97, 123, C0),
\+ C0 == CNext,
append(R, [C0], Replacement)
},
replace([CNext|T]).
replace(Input) --> replacement(R, Replacement),
{Input = [C|T],
\+ C == 63,
append(R, [C], Replacement)
},
replace(T).
replace(Input) --> replacement(R, Replacement),
{Input = [C|T],
C == 63,
random(97, 123, C0),
last(R, CPrevious),
\+ C0 == CPrevious,
append(R, [C0], Replacement)
},
replace(T).
replace([]) --> [].
◇
-
Fragment referenced in 1.
Finally we’ll have a small predicate for calling the DCG using phrase/3 and formatting the result.
-
replace_qs(S, Replaced):-
phrase(replace(S), [[]], [ReplacedCodes]),
atom_codes(Replaced, ReplacedCodes).
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- replace_qs("a?z", Replaced). Replaced = adz ? (1 ms) yes | ?- replace_qs("pe?k", Replaced). Replaced = petk ? yes | ?- replace_qs("gra?te", Replaced). Replaced = gralte ? yes | ?- replace_qs("abcdefg", Replaced). Replaced = abcdefg ? yes | ?-
Part 2: Good String
You are given a string made up of lower and upper case English letters only. Write a script to return the good string of the given string. A string is called good string if it doesn’t have two adjacent same characters, one in upper case and other is lower case.
Let’s use DCGs again! This will proceed in a way very similar to Part 1.
Some helper rules to track the state of the deletions of the ”bad pairs“. The state will be maintained as modifications of the original string. This may seem a little unusual at first, we aren’t iterating over the string, rather we are iterating over all possible bad pairs. Maybe this use of a DCG is a little clunky, but why let that stop us!
(I say this is “clunky” because here we’re mainly using DCG notation simply as an alternative to ordinary recursion. There’s nothing being parsed per se and there is nothing especially interesting about the list being processed.)
-
deletion(Deletion), [Deletion] --> [Deletion].
deletion(D, Deletion), [Deletion] --> [D].
◇
-
Fragment referenced in 5.
-
bad_pair([], _):- false.
bad_pair(S, P):-
member(X, S),
member(Y, S),
\+ X == Y,
nth(I, S, X),
nth(J, S, Y),
succ(I, J),
(X is Y + 32; X is Y - 32), P = [I, J], !.
◇
-
Fragment referenced in 5.
The main DCG rules.
-
make_good(S) --> deletion(D, Deletion),
{D == [], \+ S == [], Deletion = S},
make_good(S).
make_good(S) --> deletion(D, Deletion),
{\+ D == [],
bad_pair(S, P),
[I, _] = P,
I > 1,
prefix(Prefix, S),
length(Prefix, I0),
I0 is I - 1,
append(Prefix, [_, _|Rest], S),
append(Prefix, Rest, Deletion)
},
make_good(Deletion).
make_good(S) --> deletion(D, Deletion),
{\+ D == [],
bad_pair(S, P),
[I, _] = P,
I == 1,
append([_, _], Deletion, S)
},
make_good(Deletion).
make_good(S) --> deletion(_, Deletion),
{\+ bad_pair(S, _),
Deletion = S}.
make_good([]) --> [].
◇
-
Fragment referenced in 5.
Finally we’ll have a small predicate for calling the DCG using phrase/3.
-
make_good_string(S, Good):-
phrase(make_good(S), [[]], [GoodCodes]),
atom_codes(Good, GoodCodes), !.
◇
-
Fragment referenced in 5.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- make_good_string("WeEeekly", Good). Good = ’Weekly’ (1 ms) yes | ?- make_good_string("abBAdD", Good). Good = ’’ yes | ?- make_good_string("abc", Good). Good = abc yes | ?-
References
posted at: 19:32 by: Adam Russell | path: /prolog | permanent link to this entry
2025-07-06
A Good String Is Irreplaceable
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Replace all ?
You are given a string containing only lower case English letters and ?. Write a script to replace all ? in the given string so that the string doesn’t contain consecutive repeating characters.
The core of the solution is contained in a single subroutine. The resulting code can be contained in a single file.
The approach we take is to randomly select a new letter and test to make sure that it does not match the preceding or succeeding letter.
-
sub replace_all{
my($s) = @_;
my @s = split //, $s;
my @r = ();
{
my $c = shift @s;
my $before = pop @r;
my $after = shift @s;
my $replace;
if($c eq q/?/){
push @r, $before, $replace if $before;
push @r, $replace if!$before;
}
else{
push @r, $before, $c if $before;
push @r, $c if!$before;
}
unshift @s, $after if $after;
redo if $after;
}
return join q//, @r;
}
◇
Finding the replacement is done in a loop that repeatedly tries to find a relacement that does not match the preceding or following character. Since the number of potential conflicts is so small this will not (most likely require many iterations.
Just to make sure things work as expected we’ll define a few short tests.
-
MAIN:{
say replace_all q/a?z/;
say replace_all q/pe?k/;
say replace_all q/gra?te/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl atz peck graqte
Part 2: Good String
You are given a string made up of lower and upper case English letters only. Write a script to return the good string of the given string. A string is called good string if it doesn’t have two adjacent same characters, one in upper case and other is lower case.
We’ll define a subroutine for detecting and returning non-good pairs of letters. We know we’re done when this subroutine returns undef.
We’ll call these pairs of letters bad pairs. To see if we have a matching pair we’ll just compare the ascii values.
-
sub bad_pair{
my($s) = @_;
my @s = split q//, $s;
return undef if!@s;
{
my($x, $y) = (ord shift @s, ord shift @s);
if($x == $y + 32 || $x == $y - 32){
return chr($x) . chr($y);
}
unshift @s, chr($y);
redo unless @s == 1;
}
return undef;
}
◇
-
Fragment referenced in 5.
We use that bad_pair subroutine repeatedly in a loop until all bad pairs are removed.
-
sub make_good{
my($s) = @_;
{
my $bad_pair = bad_pair $s;
$s =~ s/$bad_pair// if $bad_pair;
redo if bad_pair $s;
}
return $s;
}
◇
-
Fragment referenced in 5.
The main section is just some basic tests.
-
MAIN:{
say make_good q/WeEeekly/;
say make_good q/abBAdD/;
say make_good q/abc/;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl perl/ch-2.pl Weekly abc
References
posted at: 17:39 by: Adam Russell | path: /perl | permanent link to this entry
2025-06-29
The Weekly Challenge 327 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Missing Integers
You are given an array of n integers. Write a script to find all the missing integers in the range 1..n in the given array.
Our solution is short and will be contained in a single file that has the following structure.
This problem is straightforward to solve using member/2.
-
missing_integers(L, Missing):-
length(L, Length),
findall(M, (
between(1, Length, M),
\+ member(M, L)
), Missing).
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- missing_integers([1, 2, 1, 3, 2, 5], Missing). Missing = [4,6] yes | ?- missing_integers([1, 1, 1], Missing). Missing = [2,3] yes | ?- missing_integers([2, 2, 1], Missing). Missing = [3] yes | ?-
Part 2: MAD
You are given an array of distinct integers. Write a script to find all pairs of elements with minimum absolute difference (MAD) of any two elements.
The code required is fairly small, we’ll just need a single predicate and use GNU Prolog’s clp(fd) solver.
This is a good use of GNU Prolog’s clp(fd) solver. We set up the finite domain variables I and J to take values from the given list. We then find the minimum value of the differences and return all pairs having satisfied that constraint.
-
mad(L, Pairs):-
fd_max_integer(MAX_INT),
fd_domain([I, J], L),
fd_domain(D, 1, MAX_INT),
J #> I,
fd_minimize((D #= J - I, fd_labeling([D])), D),
findall(Pair, (fd_labeling([I, J]), Pair = [I, J]), Pairs).
◇
-
Fragment referenced in 3.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- mad([4, 1, 2, 3], Pairs). Pairs = [[1,2],[2,3],[3,4]] yes | ?- mad([1, 3, 7, 11, 15], Pairs). Pairs = [[1,3]] yes | ?- mad([1, 5, 3, 8], Pairs). Pairs = [[1,3],[3,5]] yes | ?-
References
posted at: 15:28 by: Adam Russell | path: /prolog | permanent link to this entry
Missing Integers Don’t Make Me MAD, Just Disappointed
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Missing Integers
You are given an array of n integers. Write a script to find all the missing integers in the range 1..n in the given array.
The core of the solution is contained in a single subroutine. The resulting code can be contained in a single file.
The approach we take is to use the given array as hash keys. Then we’ll iterate over the range 1..n and see which hash keys are missing.
-
sub find_missing{
my %h = ();
my @missing = ();
do{ $h{$_} = -1 } for @_;
@missing = grep {!exists($h{$_})} 1 .. @_;
return @missing;
}
◇
-
Fragment referenced in 1.
Just to make sure things work as expected we’ll define a few short tests.
-
MAIN:{
say q/(/ . join(q/, /, find_missing 1, 2, 1, 3, 2, 5) . q/)/;
say q/(/ . join(q/, /, find_missing 1, 1, 1) . q/)/;
say q/(/ . join(q/, /, find_missing 2, 2, 1) . q/)/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl (4, 6) (2, 3) (3)
Part 2: MAD
You are given an array of distinct integers. Write a script to find all pairs of elements with minimum absolute difference (MAD) of any two elements.
We’ll use a hash based approach like we did in Part 1. The amount of code is small, just a single subroutine.
Since we need to have a nested loop to access all pairs we’ll make an effort to only do it once. What we’ll do is store the pairs in a list keyed by the differences. We’ll also track the minimum difference in a variable to avoid sorting to find it later.
-
sub mad_pairs{
my %mad = ();
my $mad = ~0;
for my $i (0 .. @_ - 1){
for my $j ($i + 1 .. @_ - 1){
my $d = abs($_[$i] - $_[$j]);
$mad = $d if $d < $mad;
push @{$mad{$d}}, [$_[$i], $_[$j]];
}
}
return @{$mad{$mad}};
}
◇
-
Fragment referenced in 4.
The main section is just some basic tests. Yeah, we’ll do lazy string formatting with chop!
-
MAIN:{
my $s = q//;
do{
$s .= q/[/ . join(q/, /, @{$_}) . q/], /;
} for mad_pairs 4, 1, 2, 3;
chop $s;
chop $s;
say $s;
$s = q//;
do{
$s .= q/[/ . join(q/, /, @{$_}) . q/], /;
} for mad_pairs 1, 3, 7, 11, 15;
chop $s;
chop $s;
say $s;
$s = q//;
do{
$s .= q/[/ . join(q/, /, @{$_}) . q/], /;
} for mad_pairs 1, 5, 3, 8;
chop $s;
chop $s;
say $s;
$s = q//;
}
◇
-
Fragment referenced in 4.
Sample Run
$ perl perl/ch-2.pl [4, 3], [1, 2], [2, 3] [1, 3] [1, 3], [5, 3]
References
posted at: 12:09 by: Adam Russell | path: /perl | permanent link to this entry
2025-06-22
The Weekly Challenge 326 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Day of the Year
You are given a date in the format YYYY-MM-DD. Write a script to find day number of the year that the given date represent.
Our solution is short, it involves just a couple of computations, and will be contained in a single file that has the following structure.
We’ll put the determination of whether a year is a leap year or not into its own predicate.
-
leap_year(Year):-
M1 is Year mod 4,
M2 is Year mod 100,
M3 is Year mod 400,
((M1 == 0, \+ M2 == 0);
(M1 == 0, M2 == 0, M3 == 0)).
◇
-
Fragment referenced in 1.
Similarly, we’ll put the calculation of the number of February days in its own predicate.
-
february_days(Year, Days):-
leap_year(Year),
Days = 29.
february_days(_, Days):-
Days = 28.
◇
-
Fragment referenced in 1.
One more utility predicate, which splits the input into day, month, and year values.
-
day_month_year(S, Day, Month, Year):-
append(Y, [45|T], S),
append(M, [45|D], T),
number_codes(Day, D),
number_codes(Month, M),
number_codes(Year, Y).
◇
-
Fragment referenced in 1.
Finally, let’s compute the day of the year.
-
day_of_year(Date, DayOfYear) :-
day_month_year(Date, Day, Month, Year),
february_days(Year, FebruaryDays),
DaysInMonth = [31, FebruaryDays, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31],
succ(M, Month),
length(Prefix, M),
prefix(Prefix, DaysInMonth),
sum_list(Prefix, MonthSum),
DayOfYear is MonthSum + Day.
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- day_of_year("2025-02-02", DayOfYear). DayOfYear = 33 ? yes | ?- day_of_year("2025-04-10", DayOfYear). DayOfYear = 100 ? yes | ?- day_of_year("2025-09-07", DayOfYear). DayOfYear = 250 ? yes | ?-
Part 2: Decompressed List
You are given an array of positive integers having even elements. Write a script to to return the decompress list. To decompress, pick adjacent pair (i, j) and replace it with j, i times.
The code required is fairly small, we’ll just need a couple of predicates.
We’ll define a DCG to “decompress”the list. First, let’s have some predicates for maintaining the state of the decompression as it proceeds.
-
decompression(Decompression), [Decompression] --> [Decompression].
decompression(D, Decompression), [Decompression] --> [D].
◇
-
Fragment referenced in 6.
The DCG for this is not so complex. Mainly we need to be concerned with maintaining the state of the decompression as we process the list.
-
decompress(Input) --> decompression(D, Decompression),
{Input = [I, J|T],
length(L, I),
maplist(=(J), L),
append(D, L, Decompression)
},
decompress(T).
decompress([]) --> [].
◇
-
Fragment referenced in 6.
Finally, let’s wrap the calls to the DCG in a small predicate using phrase/3.
-
decompress_list(L, Decompressed):-
phrase(decompress(L), [[]], [Decompressed]).
◇
-
Fragment referenced in 6.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- decompress_list([1, 3, 2, 4], Decompressed). Decompressed = [3,4,4] yes | ?- decompress_list([1, 1, 2, 2], Decompressed). Decompressed = [1,2,2] yes | ?- decompress_list([3, 1, 3, 2], Decompressed). Decompressed = [1,1,1,2,2,2] yes | ?-
References
posted at: 18:45 by: Adam Russell | path: /prolog | permanent link to this entry
The Day We Decompress
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Day of the Year
You are given a date in the format YYYY-MM-DD. Write a script to find day number of the year that the given date represent.
The core of the solution is contained in a main loop. The resulting code can be contained in a single file.
The answer is arrived at via a fairly straightforward calculation.
-
sub day_of_year {
my ($date) = @_;
my $day_of_year = 0;
my ($year, $month, $day) = split /-/, $date;
my @days_in_month = (31, $february_days, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
$day_of_year += $days_in_month[$_] for (0 .. $month - 2);
$day_of_year += $day;
return $day_of_year;
}
◇
Let’s break the logic for computing a leap year into it’s own section. A leap year occurs every 4 years, except for years that are divisible by 100, unless they are also divisible by 400.
Just to make sure things work as expected we’ll define a few short tests. The double chop is just a lazy way to make sure there aren’t any trailing commas in the output.
-
MAIN:{
say day_of_year q/2025-02-02/;
say day_of_year q/2025-04-10/;
say day_of_year q/2025-09-07/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 33 100 250
Part 2: Decompressed List
You are given an array of positive integers having even elements. Write a script to to return the decompress list. To decompress, pick adjacent pair (i, j) and replace it with j, i times.
For fun let’s use recursion!
Sometimes when I write a recursive subroutine in Perl I use a reference variable to set the return value. Other times I just use an ordinary return. In some cases, for convenience, I’ll do this with two subroutines. One of these is a wrapper which calls the main recursion.
For this problem I’ll do something a little different. I’ll have one subroutine and for each recursive call I’ll add in an array reference to hold the accumulating return value.
Note that we take advantage of Perl’s automatic list flattening when pushing to the array reference holding the new list we are building.
-
sub decompress_list{
my $r = shift @_;
if(!ref($r) || ref($r) ne q/ARRAY/){
unshift @_, $r;
$r = [];
}
unless(@_ == 0){
my $i = shift @_;
my $j = shift @_;
push @{$r}, ($j) x $i;
decompress_list($r, @_);
}
else{
return @{$r};
}
}
◇
-
Fragment referenced in 5.
The main section is just some basic tests.
-
MAIN:{
say join q/, /, decompress_list 1, 3, 2, 4;
say join q/, /, decompress_list 1, 1, 2, 2;
say join q/, /, decompress_list 3, 1, 3, 2;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl perl/ch-2.pl 3, 4, 4 1, 2, 2 1, 1, 1, 2, 2, 2
References
posted at: 16:45 by: Adam Russell | path: /perl | permanent link to this entry
2025-06-14
The Weekly Challenge 325 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Consecutive One
You are given a binary array containing only 0 or/and 1. Write a script to find out the maximum consecutive 1 in the given array.
Our solution is short and will be contained in a single file that has the following structure.
We’ll define a DCG to count the ones in the list. First, let’s have some predicates for maintaining the state of the count of consecutive ones.
-
consecutive_ones(Consecutive), [Consecutive] --> [Consecutive].
consecutive_ones(C, Consecutive), [Consecutive] --> [C].
◇
-
Fragment referenced in 1.
The DCG for this is not so complex. Mainly we need to be concerned with maintaining the state of the count as we see each list element.
-
count_ones(Input) --> consecutive_ones(C, Consecutive),
{Input = [H|T],
H == 1,
[Count, Maximum] = C,
succ(Count, Count1),
((Count1 > Maximum, Consecutive = [Count1, Count1]);
(Consecutive = [Count1, Maximum]))
},
count_ones(T).
count_ones(Input) --> consecutive_ones(C, Consecutive),
{Input = [H|T],
H == 0,
[_, Maximum] = C,
Consecutive = [0, Maximum]},
count_ones(T).
count_ones([]) --> [].
◇
-
Fragment referenced in 1.
Finally, let’s wrap the calls to the DCG in a small predicate using phrase/3.
-
consecutive_ones(L, MaximumConsecutive):-
phrase(count_ones(L), [[0, 0]], [Output]), !,
[_, MaximumConsecutive] = Output.
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- consecutive_ones([0, 1, 1, 0, 1, 1, 1], MaximumCount). MaximumCount = 3 yes | ?- consecutive_ones([0, 0, 0, 0], MaximumCount). MaximumCount = 0 yes | ?- consecutive_ones([1, 0, 1, 0, 1, 1], MaximumCount). MaximumCount = 2 yes | ?-
Part 2: Final Price
You are given an array of item prices. Write a script to find out the final price of each items in the given array. There is a special discount scheme going on. If there’s an item with a lower or equal price later in the list, you get a discount equal to that later price (the first one you find in order).
The code required is fairly small, we’ll just need a couple of predicates.
Given a list and a price find the next smallest price in the list.
-
next_smallest([], _, 0).
next_smallest([H|_], Price, H):-
H =< Price, !.
next_smallest([H|T], Price, LowestPrice):-
H > Price,
next_smallest(T, Price, LowestPrice).
◇
-
Fragment referenced in 5.
-
compute_lowest([], []).
compute_lowest([H|T], [LowestPrice|LowestPrices1]):-
compute_lowest(T, LowestPrices1),
next_smallest(T, H, Discount),
LowestPrice is H - Discount.
◇
-
Fragment referenced in 5.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- compute_lowest([8, 4, 6, 2, 3], FinalPrices). FinalPrices = [4,2,4,2,3] yes | ?- compute_lowest([1, 2, 3, 4, 5], FinalPrices). FinalPrices = [1,2,3,4,5] yes | ?- compute_lowest([7, 1, 1, 5], FinalPrices). FinalPrices = [6,0,1,5] yes | ?-
References
posted at: 15:33 by: Adam Russell | path: /prolog | permanent link to this entry
2025-06-12
Consecutive Search for Discount Prices
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Consecutive One
You are given a binary array containing only 0 or/and 1. Write a script to find out the maximum consecutive 1 in the given array.
The core of the solution is contained in a main loop. The resulting code can be contained in a single file.
We’ll use a recursive procedure, which we’ll call from a subroutine which sets up some variables. We’ll pass scalar references to a recursive subroutine. When the recursion completes the $max_consecutive variable will hold the final answer.
Now, let’s define our recursion. We’ll terminate the recursion when we’ve exhausted the input array.
-
sub consecutive_one_r{
my($i, $consecutive, $max_consecutive) = @_;
my $x;
unless(@{$i} == 0){
$x = pop @{$i};
if($x == 0){
$$max_consecutive = $$consecutive if $$consecutive > $$max_consecutive;
$$consecutive = 0;
}
if($x == 1){
$$consecutive++;
}
consecutive_one_r($i, $consecutive, $max_consecutive);
}
elsif(@{$i} == 1){
$x = pop @{$i};
if($x == 0){
$$max_consecutive = $$consecutive if $$consecutive > $$max_consecutive;
}
if($x == 1){
$$consecutive++;
$$max_consecutive = $$consecutive if $$consecutive > $$max_consecutive;
}
consecutive_one_r($i, $consecutive, $max_consecutive);
}
}
◇
Just to make sure things work as expected we’ll define a few short tests. The double chop is just a lazy way to make sure there aren’t any trailing commas in the output.
-
MAIN:{
say consecutive_one(0, 1, 1, 0, 1, 1, 1);
say consecutive_one(0, 0, 0, 0);
say consecutive_one(1, 0, 1, 0, 1, 1);
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 3 0 2
Part 2: Final Price
You are given an array of item prices. Write a script to find out the final price of each items in the given array. There is a special discount scheme going on. If there’s an item with a lower or equal price later in the list, you get a discount equal to that later price (the first one you find in order).
Hey, let’s use recursion again for this too!
The main section is just some basic tests.
-
MAIN:{
say join q/, /, calculate_lowest_prices 8, 4, 6, 2, 3;
say join q/, /, calculate_lowest_prices 1, 2, 3, 4, 5;
say join q/, /, calculate_lowest_prices 7, 1, 1, 5;
}
◇
-
Fragment referenced in 5.
First, let’s introduce a recursive subroutine that scans ahead and finds the next lowest price in the list. As in part one we’ll use a scalar reference.
With that subroutine defined we can use it to solve the main task at hand.
Sample Run
$ perl perl/ch-2.pl 4, 2, 4, 2, 3 1, 2, 3, 4, 5 6, 0, 1, 5
References
posted at: 22:13 by: Adam Russell | path: /perl | permanent link to this entry
2025-06-08
The Weekly Challenge 324 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: 2D Array
You are given an array of integers and two integers $r and $c. Write a script to create two dimension array having $r rows and $c columns using the given array.
Our solution is short and will be contained in a single file that has the following structure.
We’ll use a straightforward recursive approach.
-
create_array(_, 0, _, []).
create_array(L, Rows, Columns, [Row|T]) :-
create_row(L, Columns, Row, L1),
R is Rows - 1,
create_array(L1, R, Columns, T).
create_row(L, 0, [], L).
create_row([H|T], Columns, [H|Row], L) :-
C is Columns - 1,
create_row(T, C, Row, L).
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- create_array([1, 2, 3, 4], 2, 2, TwoDArray). TwoDArray = [[1,2],[3,4]] ? yes | ?- create_array([1, 2, 3], 1, 3, TwoDArray). TwoDArray = [[1,2,3]] ? yes | ?- create_array([1, 2, 3, 4], 4, 1, TwoDArray). TwoDArray = [[1],[2],[3],[4]] ? yes | ?-
Part 2: Total XOR
You are given an array of integers. Write a script to return the sum of total XOR for every subset of given array.
GNU Prolog has a sublist/2 predicate which will generate all needed subsets on backtracking. We’ll use this inside of a findall/3. The code required is fairly small, although we’ll define a couple of small utility predicates.
-
total_xor(L, Total):-
findall(S, (
sublist(S, L),
\+ S = []
), SubLists),
maplist(combine, SubLists, Combined),
maplist(subtotal, Combined, SubTotals),
sum_list(SubTotals, Total).
◇
-
Fragment referenced in 3.
-
combine([], 0).
combine([H|T], Combined):-
combine(T, Combined1),
Combined = xor(H, Combined1).
◇
-
Fragment referenced in 3.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- total_xor([1, 3], Total). Total = 6 yes | ?- total_xor([5, 1, 6], Total). Total = 28 yes | ?- total_xor([3, 4, 5, 6, 7, 8], Total). Total = 480 yes | ?-
References
posted at: 14:40 by: Adam Russell | path: /prolog | permanent link to this entry
Two Dimensional XOR Not?
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: 2D Array
You are given an array of integers and two integers $r and $c. Write a script to create two dimension array having $r rows and $c columns using the given array.
The core of the solution is contained in a main loop. The resulting code can be contained in a single file.
-
sub create_array{
my($i, $r, $c) = @_;
my @a = ();
for (0 .. $r - 1){
my $row = [];
for (0 .. $c - 1){
push @{$row}, shift @{$i};
}
push @a, $row;
}
return @a;
}
◇
-
Fragment referenced in 1.
Just to make sure things work as expected we’ll define a few short tests. The double chop is just a lazy way to make sure there aren’t any trailing commas in the output.
-
MAIN:{
my $s = q//;
$s .= q/(/;
do{
$s.= (q/[/ . join(q/, /, @{$_}) . q/], /);
} for create_array [1, 2, 3, 4], 2, 2;
chop $s;
chop $s;
$s .= q/)/;
say $s;
$s = q//;
$s .= q/(/;
do{
$s.= (q/[/ . join(q/, /, @{$_}) . q/], /);
} for create_array [1, 2, 3], 1, 3;
chop $s;
chop $s;
$s .= q/)/;
say $s;
$s = q//;
$s .= q/(/;
do{
$s.= (q/[/ . join(q/, /, @{$_}) . q/], /);
} for create_array [1, 2, 3, 4], 4, 1;
chop $s;
chop $s;
$s .= q/)/;
say $s;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl ([1, 2], [3, 4]) ([1, 2, 3]) ([1], [2], [3], [4])
Part 2: Total XOR
You are given an array of integers. Write a script to return the sum of total XOR for every subset of given array.
This is another short one, but with a slightly more involved solution. We are going to compute the Power Set (set of all subsets) of the given array of integers and then for each of these sub-arrays compute and sum the XOR results.
The main section is just some basic tests.
-
MAIN:{
say calculate_total_xor 1, 3;
say calculate_total_xor 5, 1, 6;
say calculate_total_xor 3, 4, 5, 6, 7, 8;
}
◇
-
Fragment referenced in 4.
-
sub calculate_total_xor{
my $total = 0;
for my $a (power_set @_){
my $t = 0;
$t = eval join q/ ^ /, ($t, @{$a});
$total += $t;
}
return $total;
}
◇
-
Fragment referenced in 4.
The Power Set can be computed by using a binary counter. Let’s say we have N elements of the set. We start at 0 x N and continue to 1 x N. At each iteration we compose a subarray by including the ith element from the original array if the ith bit is set. Actually, we arent going to start at 0 x N because we want to exclude the empty set for the purposes of the later XOR computation.
-
sub power_set{
my @a = ();
for my $i (1 .. 2 ** @_- 1){
my @digits = ();
for my $j (0 .. @_ - 1){
push @digits, $_[$j] if 1 == ($i >> $j & 1);
}
push @a, \@digits;
}
return @a;
}
◇
-
Fragment referenced in 4.
Sample Run
$ perl perl/ch-2.pl 6 28 480
References
Power Set Defined
Power Set Calculcation (C++) from TWC 141
The Weekly Challenge 324
Generated Code
posted at: 12:36 by: Adam Russell | path: /perl | permanent link to this entry
2025-06-06
The Weekly Challenge 323 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Increment Decrement
You are given a list of operations. Write a script to return the final value after performing the given operations in order. The initial value is always 0.
Our solution will be contained in a single file that has the following structure.
We’ll use a DCG approach to process the input and maintain the state of the variables.
First, let’s have some predicates for maintaining the state of the variables as the DCG processes the input.
-
variables(VariableState), [VariableState] --> [VariableState].
variables(V, VariableState), [VariableState] --> [V].
◇
-
Fragment referenced in 1.
Now we need to process the input, which we’ll treat as lists of character codes.
-
process(Input) --> variables(V, VariableState),
{Input = [Code1, Code2, Code3 | Codes],
Code1 == 43, Code2 == 43, Code3 >= 97,
Code3 =< 122,
increment_variable(Code3, V, VariableState)},
process(Codes).
process(Input) --> variables(V, VariableState),
{Input = [Code1, Code2, Code3 | Codes],
Code2 == 43, Code3 == 43, Code1 >= 97,
Code1 =< 122,
increment_variable(Code1, V, VariableState)},
process(Codes).
process(Input) --> variables(V, VariableState),
{Input = [Code1, Code2, Code3 | Codes],
Code1 == 45, Code2 == 45, Code3 >= 97,
Code3 =< 122,
decrement_variable(Code3, V, VariableState)},
process(Codes).
process(Input) --> variables(V, VariableState),
{Input = [Code1, Code2, Code3 | Codes],
Code2 == 45, Code3 == 45, Code1 >= 97,
Code1 =< 122,
decrement_variable(Code1, V, VariableState)},
process(Codes).
process(Input) --> variables(V, VariableState),
{Input = [Code | Codes],
Code >= 97, Code =< 122,
declare_variable(Code, V, VariableState)},
process(Codes).
process(Input) --> {Input = [Code | Codes],
Code == 32},
process(Codes).
process([]) --> [].
◇
-
Fragment referenced in 1.
We’ll define some utility predicates for updating the state of the variables in our DCG input.
-
increment_variable(X, U, V):-
member(X-I, U),
delete(U, X-I, U1),
I1 is I + 1,
append([X-I1], U1, V).
increment_variable(X, U, V):-
\+ member(X-_, U),
append([X-1], U, V).
decrement_variable(X, U, V):-
member(X-I, U),
delete(U, X-I, U1),
I1 is I - 1,
append([X-I1], U1, V).
decrement_variable(X, U, V):-
\+ member(X-_, U),
append([X-(-1)], U, V).
declare_variable(X, U, V):-
delete(U, X-_, U1),
append([X-0], U1, V).
◇
-
Fragment referenced in 1.
One more small utility predicate. This one is for displaying the final results. It’s intended to be called from maplist/2.
-
show_variables(X-I):-
atom_codes(A, [X]),
write(A),
write(’:␣’),
write(I), nl.
◇
-
Fragment referenced in 1.
Finally, let’s wrap the calls to the DCG in a small predicate using phrase/3.
-
increment_decrement(Input):-
phrase(process(Input), [[]], [Output]), !,
maplist(show_variables, Output).
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- increment_decrement("--x␣x++␣x++"). x: 1 yes | ?- increment_decrement("x++␣++x␣x++"). x: 3 (1 ms) yes | ?- increment_decrement("x++␣++x␣--x␣x--"). x: 0 yes | ?- increment_decrement("a␣b␣c␣a++␣b++␣c++␣++a␣++b␣++c␣--a␣--b␣--c␣a--␣b--␣c--␣a++␣++b␣c++"). c: 1 b: 1 a: 1 yes | ?-
Part 2: Tax Amount
You are given an income amount and tax brackets. Write a script to calculate the total tax amount.
While a DCG approach is also certainly possible for this second part we’ll go with a more plain recursive solution.
The code is simple enough that it is pretty explainable in one single code section.
-
compute_taxes(Income, TaxBrackets, Tax):-
compute_taxes(Income, TaxBrackets, 0, 0, Tax).
compute_taxes(0, _, 0, 0, 0).
compute_taxes(Income, [[Limit, Rate]|TaxBrackets], Taxable, Taxed, Tax):-
Limit =< Income,
Taxable1 is Limit - Taxable,
Taxed1 is Taxed + Taxable1,
compute_taxes(Income, TaxBrackets, Taxable1, Taxed1, Tax1),
Tax is Tax1 + (Taxable1 * (Rate/100)).
compute_taxes(Income, [[Limit, Rate]|_], _, Taxed, Tax):-
Limit > Income,
Tax is ((Income - Taxed) * (Rate/100)).
◇
-
Fragment referenced in 7.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- compute_taxes(10, [[3, 50], [7, 10], [12,25]], Tax), format("$~2f", [Tax]). $2.65 Tax = 2.6499999999999999 ? yes | ?- compute_taxes(2, [[1, 0], [4, 25], [5,50]], Tax), format("$~2f", [Tax]). $0.25 Tax = 0.25 ? yes | ?- compute_taxes(0, [[2, 50]], Tax), format("$~2f", [Tax]). $0.00 Tax = 0 ? yes | ?-
References
posted at: 17:05 by: Adam Russell | path: /prolog | permanent link to this entry
2025-06-05
Incremental Taxation
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Increment Decrement
You are given a list of operations. Write a script to return the final value after performing the given operations in order. The initial value is always 0.
Let’s entertain ourselves with an over engineered solution! We’ll use Parse::Yapp to handle incrementing and decrementing any single letter variable. Or, to put it another way, we’ll define a tiny language which consists of single letter variables that do not require declaration, are only of unsigned integer type, and are automatically initialized to zero. The only operations on these variables are the increment and decrement operations from the problem statement. At the completion of the parser’s execution we will print the final values of each variable.
The majority of the work will be done in the .yp yapp grammar definition file. We’ll focus on this file first.
The declarations section will have some token definitions and a global variable declaration.
For our simple language we’re just going to define a few tokens: the increment and decrement operators, our single letter variables.
We’re going to define a single global variable which will be used to track the state of each variable.
The rules section defines the actions of our increment and decrement operations in both prefix and postfix form. We’ll also allow for a completely optional variable declaration which is just placing a single letter variable by itself
-
program: statement {$variable_state}
| program statement
;
statement: variable_declaration
| increment_variable
| decrement_variable
;
variable_declaration: LETTER {$variable_state->{$_[1]} = 0}
;
increment_variable: INCREMENT LETTER {$variable_state->{$_[2]}++}
| LETTER INCREMENT {$variable_state->{$_[1]}++}
;
decrement_variable: DECREMENT LETTER {$variable_state->{$_[2]}--}
| LETTER DECREMENT {$variable_state->{$_[1]}--}
;
◇
The final section of the grammar definition file is, historically, called programs. This is where we have Perl code for the lexer, error handing, and a parse function which provides the main point of execution from code that wants to call the parser that has been generated from the grammar.
The parse function is for the convenience of calling the generated parser from other code. yapp will generate a module and this will be the module’s method used by other code to execute the parser against a given input.
Notice here that we are squashing white space, both tabs and newlines, using tr. This reduces all tabs and newlines to a single space. This eases further processing since extra whitespace is just ignored, according to the rules we’ve been given.
Also notice the return value from parsing. In the rules section we provide a return value, a hash reference, in the final action code block executed.
-
sub parse{
my($self, $input) = @_;
$input =~ tr/\t/ /s;
$input =~ tr/\n/ /s;
$self->YYData->{INPUT} = $input;
my $result = $self->YYParse(yylex => \&lexer, yyerror => \&error);
return $result;
}
◇
-
Fragment referenced in 6.
This is really just about the most minimal error handling function there can be! All this does is print “syntax error”when the parser encounters a problem.
-
sub error{
exists $_[0]->YYData->{ERRMSG}
and do{
print $_[0]->YYData->{ERRMSG};
return;
};
print "syntax␣error\n";
}
◇
-
Fragment referenced in 6.
The lexer function is called repeatedly for the entire input. Regular expressions are used to identify tokens (the ones declared at the top of the file) and pass them along for the rules processing.
-
sub lexer{
my($parser) = @_;
$parser->YYData->{INPUT} or return(q//, undef);
$parser->YYData->{INPUT} =~ s/^[ \t]//g;
##
# send tokens to parser
##
for($parser->YYData->{INPUT}){
s/^(\s+)// and return (q/SPACE/, $1);
s/^([a-z]{1})// and return (q/LETTER/, $1);
s/^(\+\+)// and return (q/INCREMENT/, $1);
s/^(--)// and return (q/DECREMENT/, $1);
}
}
◇
-
Fragment referenced in 6.
There’s one more function we should add. The reason for it is a little complex. Variables defined in the declarations section are considered static and are stored in the lexical pad of the package. So each new invocation of the parse() method will re-use the same variables. They are not cleared or reset. So, we’ll define a subroutine which will clear this for us manually.
Let’s define a small file to drive some tests.
The preamble to the test driver sets the minimum perl version to be the most recent one, to take advantage of all recent changes. We also include the generated module file whihc yapp creates. For test purposes we’ll define some constants, taken from TWC’s examples.
-
use constant TEST0 => q/--x x++ x++/;
use constant TEST1 => q/x++ ++x x++/;
use constant TEST2 => q/x++ ++x --x x--/;
use constant COMPLEX_TEST => <<~END_TEST;
a b c
a++ b++ c++
++a ++b ++c
--a --b --c
a-- b-- c--
a++ ++b c++
END_TEST
◇
-
Fragment referenced in 12.
For printing the results in a nice way we’ll define a small subroutine to display the return value from the parser.
-
sub print_variables{
my($results) = @_;
for my $k (keys %{$results}){
print $k;
say qq/:\t$results->{$k}/;
}
}
◇
-
Fragment referenced in 11.
-
MAIN:{
my $parser = IncrementDecrement->new();
say TEST0;
say print_variables $parser->parse(TEST0);
say TEST1;
$parser->clear();
say print_variables $parser->parse(TEST1);
say TEST2;
$parser->clear();
say print_variables $parser->parse(TEST2);
say COMPLEX_TEST;
$parser->clear();
say print_variables $parser->parse(COMPLEX_TEST);
}
◇
-
Fragment referenced in 11.
Sample Run
$ yapp -m IncrementDecrement perl/IncrementDecrement.yp; mv IncrementDecrement.pm perl; perl -Iperl perl/ch-1.pl --x x++ x++ x: 1 x++ ++x x++ x: 3 x++ ++x --x x-- x: 0 a b c a++ b++ c++ ++a ++b ++c --a --b --c a-- b-- c-- a++ ++b c++ b: 1 a: 1 c: 1
Part 2: Tax Amount
You are given an income amount and tax brackets. Write a script to calculate the total tax amount.
After over doing the complexity for the first part, we’ll make this one quite a bit shorter.
The main section is just some basic tests.
-
MAIN:{
say calculate_tax 10, [[3, 50], [7, 10], [12,25]];
say calculate_tax 2, [[1, 0], [4, 25], [5,50]];
say calculate_tax 0, [[2, 50]];
}
◇
-
Fragment referenced in 16.
-
{
my $tax_bracket = shift @{$tax_brackets};
if($tax_bracket->[0] <= $income){
$taxable = $tax_bracket->[0] - $taxable;
$tax += ($taxable * ($tax_bracket->[1]/100));
$taxed += $taxable;
}
else{
$tax += (($income - $taxed) * ($tax_bracket->[1]/100));
$taxed = $income;
}
redo unless $taxed >= $income || @{$tax_brackets} == 0;
}
◇
Sample Run
$ perl perl/ch-2.pl 2.65 0.25 0
References
posted at: 22:52 by: Adam Russell | path: /perl | permanent link to this entry
2025-05-26
The Weekly Challenge 322 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1:String Format
You are given a string and a positive integer. Write a script to format the string, removing any dashes, in groups of size given by the integer. The first group can be smaller than the integer but should have at least one character. Groups should be separated by dashes.
Our solution will be contained in a single file that has the following structure.
We’ll use a DCG approach to process the string and maintain the result.
First, let’s have some predicates for maintaining the state of a character list as the DCG processes the string.
-
format_(Format), [Format] --> [Format].
format_(F, Format), [Format] --> [F].
◇
-
Fragment referenced in 1.
Now we need to process the strings, which we’ll treat as lists of character codes.
-
process(String, I, J) --> {String = [Code | Codes],
Code == 45},
process(Codes, I, J).
process(String, I, J) --> format_(F, Format),
{String = [Code | Codes],
\+ Code == 45,
succ(J, I),
char_code(C, Code),
length(Codes, L),
((L > 0, Format = [’-’, C|F]);
(Format = [C|F]))},
process(Codes, I, 0).
process(String, I, J) --> format_(F, Format),
{String = [Code | Codes],
\+ Code == 45,
succ(J, J1),
char_code(C, Code),
Format = [C|F]},
process(Codes, I, J1).
process([], _, _) --> [].
◇
-
Fragment referenced in 1.
Finally, let’s wrap the calls to the DCG in a small predicate using phrase/3. We’re going to work from right to left so we’ll use reverse/2 to input into our DCG.
-
string_format(String, I, FormattedString):-
reverse(String, R),
phrase(process(R, I, 0), [[]], [F]), !,
atom_chars(FormattedString, F).
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- string_format("ABC-D-E-F", 3, F). F = ’ABC-DEF’ yes | ?- string_format("A-BC-D-E", 2, F). F = ’A-BC-DE’ yes | ?- string_format("-A-B-CD-E", 4, F). F = ’A-BCDE’ yes | ?-
Part 2: Rank Array
You are given an array of integers. Write a script to return an array of the ranks of each element: the lowest value has rank 1, next lowest rank 2, etc. If two elements are the same then they share the same rank.
We’ll sort/2 the list of integers and then use the sroted list to look up the rank using nth/3. Remember, sort/2 removes duplicates! If it did not this approach would require extra work to first get the unique values.
This is a predicate we’ll call via maplist.
We’ll define a predicate to do an initial sort and call rank/3.
-
rank_list(L, Ranks):-
sort(L, Sorted),
maplist(rank(Sorted), L, Ranks).
◇
-
Fragment referenced in 5.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- rank_list([55, 22, 44, 33], Ranks). Ranks = [4,1,3,2] ? yes | ?- rank_list([10, 10, 10], Ranks). Ranks = [1,1,1] ? yes | ?- rank_list([5, 1, 1, 4, 3], Ranks). Ranks = [4,1,1,3,2] ? yes | ?-
References
posted at: 00:31 by: Adam Russell | path: /prolog | permanent link to this entry
2025-05-25
Ordered Format Array
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: String Format
You are given a string and a positive integer. Write a script to format the string, removing any dashes, in groups of size given by the integer. The first group can be smaller than the integer but should have at least one character. Groups should be separated by dashes.
Our solution will be pretty short, contained in just a single file that has the following structure.
The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version.
the main section is just some basic tests.
-
MAIN:{
say string_format q/ABC-D-E-F/, 3;
say string_format q/A-BC-D-E/, 2;
say string_format q/-A-B-CD-E/, 4;
}
◇
-
Fragment referenced in 1.
The approach is to maintain an array of arrays, with each sub-array being a new group of letters of the given size. We’ll process the string from right to left. This code seems to be well contained in a single subroutine. This sort of “stack processing” is straightforward enough to not require a lot of extra explanation.
-
sub string_format{
my($s, $i) = @_;
my @s = split //, $s;
my @t = ([]);
{
my $s_ = pop @s;
unless($s_ eq q/-/){
my $t_ = shift @t;
if(@{$t_} == $i){
unshift @t, $t_;
unshift @t, [$s_];
}
else{
unshift @{$t_}, $s_;
unshift @t, $t_;
}
}
redo if @s;
}
return join(q/-/, map {join q//, @{$_}} @t);
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl ABC-DEF A-BC-DE A-BCDE
Part 2: Rank Array
You are given an array of integers. Write a script to return an array of the ranks of each element:the lowest value has rank 1, next lowest rank 2, etc. If two elements are the same then they share the same rank.
Our solution will have the following structure.
The main section is just some basic tests.
-
MAIN:{
say q/(/ . join(q/, /, (rank_array 55, 22, 44, 33)) . q/)/;
say q/(/ . join(q/, /, (rank_array 10, 10, 10)) . q/)/;
say q/(/ . join(q/, /, (rank_array 5, 1, 1, 4, 3)) . q/)/;
}
◇
-
Fragment referenced in 5.
Just for fun, no sort will be used to solve this problem! What we will do instead is define a subroutine to return the number of unique elements larger than a given number. The fun comes at a cost! This is an O(n2) method.
We use a hash to determine the unique values in the given array
-
do{$h{$_} = undef} for @i;
◇
-
Fragment referenced in 7.
Here’s where we compute how many unique numbers are larger than any given one
-
sub number_larger{
my($x, $unique) = @_;
return @{$unique} - grep {$_ > $x} @{$unique};
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl perl/ch-2.pl (4, 1, 3, 2) (1, 1, 1) (4, 1, 1, 3, 2)
References
posted at: 10:27 by: Adam Russell | path: /perl | permanent link to this entry
2025-05-18
The Weekly Challenge 321 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Distinct Average
You are given an array of numbers with even length. Write a script to return the count of distinct average. The average is calculate by removing the minimum and the maximum, then average of the two.
Our solution will be pretty short, contained in just a single file that has the following structure.
We’ll define a predicate for getting the minimum/maximum pairs. These will be the first/last pairs from a sorted list.
-
first_last([], []).
first_last(Numbers, FirstLastPairs):-
nth(1, Numbers, First),
last(Numbers, Last),
append([First|Rest], [Last], Numbers),
first_last(Rest, FirstLastPairs0),
append([[First, Last]], FirstLastPairs0, FirstLastPairs).
◇
-
Fragment referenced in 1.
We just need a single predicate to sort the given list of numbers, call first_last/2, call maplist/2 with sum_list/2, sort/2 the results, and return the count of unique pairs. Since we only have pairs of numbers their averages will be the same if their sums are the same. (This also allows us to ignore potential floating point number annoyances). Also, remember that sort/2 will remove duplicates.
-
distinct_average(Numbers, DistinctAverage):-
sort(Numbers, NumbersSorted),
first_last(NumbersSorted, MinimumMaximumPairs),
maplist(sum_list, MinimumMaximumPairs, MinimumMaximumSums),
sort(MinimumMaximumSums, MinimumMaximumSumsSorted),
length(MinimumMaximumSumsSorted, DistinctAverage).
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- distinct_average([1, 2, 4, 3, 5, 6], DistinctAverage). DistinctAverage = 1 ? yes | ?- distinct_average([0, 2, 4, 8, 3, 5], DistinctAverage). DistinctAverage = 2 ? yes | ?- distinct_average([7, 3, 1, 0, 5, 9], DistinctAverage). DistinctAverage = 2 ? yes | ?-
Part 2: Backspace Compare
You are given two strings containing zero or more #. Write a script to return true if the two given strings are same by treating # as backspace.
We’ll use a DCG approach to process the strings and maintain an list of characters.
Let’s have some predicates for maintaining the state of a character list as the DCG processes the string.
-
characters(Characters), [Characters] --> [Characters].
characters(C, Characters), [Characters] --> [C].
◇
-
Fragment referenced in 4.
Now we need to process the strings, which we’ll treat as lists of character codes.
-
process(String) --> characters(C, Characters),
{String = [Code | Codes],
last(C, PreviousCharacter),
((Code \== 35, char_code(C0, Code),
append(C, [C0], Characters));
(append(Characters, [PreviousCharacter], C))), !},
process(Codes).
process([]) --> [].
◇
-
Fragment referenced in 4.
Finally, let’s wrap the calls to the DCG in a small predicate using phrase/3. This will process both strings and then compare the results.
-
backspace_compare(String1, String2):-
phrase(process(String1), [[’’]], [R1]),
delete(R1, ’’, R2),
atom_chars(Result1, R2),
phrase(process(String2), [[’’]], [R3]),
delete(R3, ’’, R4),
atom_chars(Result2, R4),
Result1 == Result2.
◇
-
Fragment referenced in 4.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- backspace_compare("ab#c", "ad#c"). yes | ?- backspace_compare("ab##", "a#b#"). yes | ?- backspace_compare("a#b", "c"). no | ?-
References
posted at: 13:02 by: Adam Russell | path: /prolog | permanent link to this entry
Back to a Unique Evaluation
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Distinct Average
You are given an array of numbers with even length. Write a script to return the count of distinct average. The average is calculate by removing the minimum and the maximum, then average of the two.
Our solution will be pretty short, contained in just a single file that has the following structure.
The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version.
the main section is just some basic tests.
-
MAIN:{
say distinct_average 1, 2, 4, 3, 5, 6;
say distinct_average 0, 2, 4, 8, 3, 5;
say distinct_average 7, 3, 1, 0, 5, 9;
}
◇
-
Fragment referenced in 1.
All the work is done in the following subroutine. This problem is straightforward enough to not require much more code than this.
To describe the details of this subroutine sections of it are separated out into their own code sections.
Sample Run
$ perl perl/ch-1.pl 1 2 2
Part 2: Backspace Compare
You are given two strings containing zero or more #. Write a script to return true if the two given strings are same by treating # as backspace.
Our solution will have the following structure.
The main section is just some basic tests.
-
MAIN:{
say backspace_compare q/ab#c/, q/ad#c/;
say backspace_compare q/ab##/, q/a#b#/;
say backspace_compare q/a#b/, q/c/;
}
◇
-
Fragment referenced in 8.
The approach is to maintain two arrays (think of them as stacks), one for each string. As we process each string we will push a character onto the stack as each non-# character is encountered. We’ll pop a character from the stack for every # encountered. When both strings have been processed we’ll compare the two resulting stacks. This code seems to be well contained in a single subroutine.
-
sub backspace_compare{
my($s, $t) = @_;
my @s = split //, $s;
my @t = split //, $t;
my @u = ();
my @v = ();
{
my $s_ = shift @s || undef;
my $t_ = shift @t || undef;
push @u, $s_ if $s_ && $s_ ne q/#/;
push @v, $t_ if $t_ && $t_ ne q/#/;
pop @u if $s_ && $s_ eq q/#/;
pop @v if $t_ && $t_ eq q/#/;
redo if @s || @t;
}
return join(q//, @u) eq join(q//, @v)?q/true/:q/false/;
}
◇
-
Fragment referenced in 8.
Sample Run
$ perl perl/ch-2.pl true true false
References
posted at: 13:01 by: Adam Russell | path: /perl | permanent link to this entry
2025-05-11
The Weekly Challenge 320 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Maximum Count
You are given an array of integers. Write a script to return the maximum between the number of positive and negative integers. Zero is neither positive nor negative.
Our solution will be pretty short, contained in just a single file that has the following structure.
We’ll define two predicates for counting the number of negative and positive numbers. These will use small helper predicates to be called via maplist.
-
identify_negatives(Number, 1):-
Number < 0.
identify_negatives(_, 0).
◇
-
Fragment referenced in 1.
-
identify_positives(Number, 1):-
Number > 0.
identify_positives(_, 0).
◇
-
Fragment referenced in 1.
-
count_negatives(Numbers, Count):-
maplist(identify_negatives, Numbers, Negatives),
sum_list(Negatives, Count).
◇
-
Fragment referenced in 1.
-
count_positives(Numbers, Count):-
maplist(identify_positives, Numbers, Positives),
sum_list(Positives, Count).
◇
-
Fragment referenced in 1.
We’ll need a predicate to tie everything together, that’s what this next one does.
-
maximum_count(Numbers, MaximumCount):-
count_negatives(Numbers, NegativesCount),
count_positives(Numbers, PositivesCount),
max_list([NegativesCount, PositivesCount], MaximumCount).
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- maximum_count([-3, -2, -1, 1, 2, 3], MaximumCount). MaximumCount = 3 ? yes | ?- maximum_count([-2, -1, 0, 0, 1], MaximumCount). MaximumCount = 2 ? yes | ?- maximum_count([1, 2, 3, 4], MaximumCount). MaximumCount = 4 ? yes | ?-
Part 2: Sum Differences
You are given an array of positive integers. Write a script to return the absolute difference between digit sum and element sum of the given array.
As in the first part, our solution will be pretty short, contained in just a single file.
The element sum is a straightforward application of the builtin predicate sum_list/2.
-
element_sum(Numbers, ElementSum):-
sum_list(Numbers, ElementSum).
◇
-
Fragment referenced in 7.
To compute the digit sum we’ll first convert them to characters, via maplist, flatten the list, convert them back to numbers, and take the sum_list.
-
digit_sum(Numbers, DigitSum):-
maplist(number_chars, Numbers, Characters),
flatten(Characters, CharactersFlattened),
maplist(char_number, CharactersFlattened, Digits),
sum_list(Digits, DigitSum).
◇
-
Fragment referenced in 7.
The above predicate, for convenience of the maplist, requires a small helper predicate to reverse the arguments of numbers_chars.
sum_difference/2 is the main predicate, which calls the others we’ve defined so far.
-
sum_differences(Numbers, Differences):-
element_sum(Numbers, ElementSum),
digit_sum(Numbers, DigitSum),
Differences is abs(DigitSum - ElementSum).
◇
-
Fragment referenced in 7.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- sum_differences([1, 23, 4, 5], SumDifferences). SumDifferences = 18 yes | ?- sum_differences([1, 2, 3, 4, 5], SumDifferences). SumDifferences = 0 yes | ?- sum_differences([1, 2, 34], SumDifferences). SumDifferences = 27 yes | ?-
References
posted at: 13:04 by: Adam Russell | path: /prolog | permanent link to this entry
2025-05-10
Summit of Count Deviation
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Maximum Count
You are given an array of integers. Write a script to return the maximum between the number of positive and negative integers. Zero is neither positive nor negative.
Our solution will be pretty short, contained in just a single file that has the following structure.
The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version.
the main section is just some basic tests.
-
MAIN:{
say maximum_count -3, -2, -1, 1, 2, 3;
say maximum_count -2, -1, 0, 0, 1;
say maximum_count 1, 2, 3, 4;
}
◇
-
Fragment referenced in 1.
All the work is done in the following subroutine.
We do the filtering with a grep.
Sample Run
$ perl perl/ch-1.pl 3 2 4
Part 2: Sum Difference
You are given an array of positive integers. Write a script to return the absolute difference between digit sum and element sum of the given array.
Our solution will be pretty short, contained in just a single file that has the following structure.
The main section is just some basic tests.
-
MAIN:{
say sum_difference 1, 23, 4, 5;
say sum_difference 1, 2, 3, 4, 5;
say sum_difference 1, 2, 34;
}
◇
-
Fragment referenced in 7.
All the work is done in the following subroutine.
We compute the digit sum by splitting each element as a string and then summing the list of digits.
The element sum is a straightforward summing of the elements.
Sample Run
$ perl perl/ch-2.pl 18 0 27
References
posted at: 19:15 by: Adam Russell | path: /perl | permanent link to this entry
2025-05-04
The Weekly Challenge 319 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Word Count
You are given a list of words containing alphabetic characters only. Write a script to return the count of words either starting with a vowel or ending with a vowel.
Our solution will be pretty short, contained in just a single file that has the following structure.
We’re going to be using character codes for this. For convenience let’s declare are vowels this way.
-
vowel(97). % a
vowel(101). % e
vowel(105). % i
vowel(111). % o
vowel(117). % u
◇
-
Fragment referenced in 1.
We’ll use a small predicate, later to be called from maplist, to check if a word starts or ends with a vowel.
-
start_end_vowel(Word, StartsEnds):-
((nth(1, Word, FirstLetter),
vowel(FirstLetter));
(last(Word, LastLetter),
vowel(LastLetter))),
StartsEnds = true.
start_end_vowel(_, -1).
◇
-
Fragment referenced in 1.
We’ll need a predicate to tie everything together, that’s what this next one does.
-
word_count(Words, Count):-
maplist(start_end_vowel, Words, StartsEndsAll),
delete(StartsEndsAll, -1, StartsEnds),
length(StartsEnds, Count).
◇
-
Fragment referenced in 1.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- word_count(["unicode", "xml", "raku", "perl"], Count). Count = 2 ? yes | ?- word_count(["the", "weekly", "challenge"], Count). Count = 2 ? yes | ?- word_count(["perl", "python", "postgres"], Count). Count = 0 yes | ?-
Part 2: Minimum Common
You are given two arrays of integers. Write a script to return the minimum integer common to both arrays. If none found return -1.
As in the first part, our solution will be pretty short, contained in just a single file.
To check for common elements is easy in Prolog. First we subtract/3 all elements of one list from the other. That will give us the unique elements. Then we’ll delete the unique elements from one of the original lists to get all common elements. After that min_list/2 determines the result.
minimum_common/3 is the main (and only) predicate we define
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- minimum_common([1, 2, 3, 4], [3, 4, 5, 6], MinimumCommon). MinimumCommon = 3 ? yes | ?- minimum_common([1, 2, 3], [2, 4], MinimumCommon). MinimumCommon = 2 ? yes | ?- minimum_common([1, 2, 3, 4], [5, 6, 7, 8], MinimumCommon). MinimumCommon = -1 yes | ?-
References
posted at: 14:47 by: Adam Russell | path: /prolog | permanent link to this entry
In the Count of Common
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Word Count
You are given a list of words containing alphabetic characters only. Write a script to return the count of words either starting with a vowel or ending with a vowel.
Our solution will be pretty short, contained in just a single file that has the following structure.
The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version.
the main section is just some basic tests.
-
MAIN:{
say word_count qw/unicode xml raku perl/;
say word_count qw/the weekly challenge/;
say word_count qw/perl python postgres/;
}
◇
-
Fragment referenced in 1.
All the work is done in the count section which contains a single small subroutine.
For clarity we’ll break that vowel check into it’s own code section. It’s not too hard. We use the beginning and ending anchors (^, $) to see if there is a character class match at the beginning or end of the word.
Sample Run
$ perl perl/ch-1.pl 2 2 0
Part 2: Minimum Common
You are given two arrays of integers. Write a script to return the minimum integer common to both arrays. If none found return -1.
As in the first part, our solution will be pretty short, contained in just a single file that has the following structure.
(The preamble is going to be the same as before, we don’t need anything extra for this problem either.)
The main section just drives a few tests.
The subroutine that gets the bulk of the solution started is in this section.
The real work is done in this section. We determine the unique elements by creating two separate hashes and then, using the keys to each hash, count the number of common elements. We then sort the common elements, if there are any, and set $minimum to be the smallest one.
-
MAIN:{
say minimum_common [1, 2, 3, 4], [3, 4, 5, 6];
say minimum_common [1, 2, 3], [2, 4];
say minimum_common [1, 2, 3, 4], [5, 6, 7, 8];
}
◇
-
Fragment referenced in 6.
Sample Run
$ perl perl/ch-2.pl 3 2 -1
References
posted at: 12:25 by: Adam Russell | path: /perl | permanent link to this entry
2025-04-27
The Weekly Challenge 318 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Group Position
You are given a string of lowercase letters. Write a script to find the position of all groups in the given string. Three or more consecutive letters form a group. Return “” if none found.
We can do this in a single predicate which uses maplist to get the groupings with a small utility predicate.
-
group(Letters, Letter, Group):-
length(Letters, LengthLetters),
delete(Letters, Letter, Deleted),
length(Deleted, LengthDeleted),
Difference is LengthLetters - LengthDeleted,
Difference >= 3,
length(G1, Difference),
maplist(=(Letter), G1),
append(G1, _, G2),
append(_, G2, Letters),
atom_codes(Group, G1).
group(_, _, nil).
◇
-
Fragment referenced in 3.
-
groupings(Word, Groupings):-
sort(Word, UniqueLetters),
maplist(group(Word), UniqueLetters, Groups),
delete(Groups, nil, Groupings).
◇
-
Fragment referenced in 3.
The rest of the code just wraps this single predicate into a file.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- groupings("abccccd", Groupings). Groupings = [cccc] ? yes | ?- groupings("aaabcddddeefff", Groupings). Groupings = [aaa,dddd,fff] ? yes | ?- groupings("abcdd", Groupings). Groupings = [] yes | ?-
Part 2: Reverse Equals
You are given two arrays of integers, each containing the same elements as the other. Write a script to return true if one array can be made to equal the other by reversing exactly one contiguous subarray.
This is going to be a quick one, but there’s going to be a few pieces we need to take care of. First we will check that we can subtract/3 the two words (character code lists) and obtain an empty list. Then we’ll check in which places the words differ. If they differ in one place or more then we’re done. Otherwise we’ll test the reversal of the sublist.
-
length(DifferenceIndices, NumberDifferences),
NumberDifferences > 0,
nth(1, DifferenceIndices, FirstIndex),
last(DifferenceIndices, LastIndex),
findall(E, (
between(FirstIndex, LastIndex, I),
nth(I, List1, E)
), SubList1),
findall(E, (
between(FirstIndex, LastIndex, I),
nth(I, List2, E)
), SubList2),
◇
-
reverse(SubList1, Reverse1),
reverse(SubList2, Reverse2),
append(SubList1, Suffix1, S1),
append(SubList2, Suffix2, S2),
append(Reverse1, Suffix1, S3),
append(Reverse2, Suffix2, S4),
append(Prefix1, S1, List1),
append(Prefix2, S2, List2),
(append(Prefix1, S3, List2); append(Prefix2, S4, List1))
◇
All these pieces will be assembled into reverse_equals/2.
Finally, let’s assemble our completed code into a single file.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- reverse_equals([3, 2, 1, 4], [1, 2, 3, 4]). true ? yes | ?- reverse_equals([1, 3, 4], [4, 1, 3]). no | ?- reverse_equals([2], [2]). yes | ?-
References
posted at: 23:10 by: Adam Russell | path: /prolog | permanent link to this entry
Group Position Reversals
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Group Position
You are given a string of lowercase letters. Write a script to find the position of all groups in the given string. Three or more consecutive letters form a group. Return “” if none found.
Here’s our one subroutine, this problem requires very little code.
-
sub groupings{
my($s) =@_;
my@groups;
my@group;
my($current, $previous);
my@letters = split //, $s;
$previous = shift@letters;
group = ($previous);
do {
$current = $_;
if($previous eq $current){
push@group, $current;
}
if($previous ne $current){
if(@group >= 3){
push@groups, [@group];
}
group = ($current);
}
$previous = $current;
} for@letters;
if(@group >= 3){
push@groups, [@group];
}
my@r = map {q/"/␣.␣join(q//,␣@{$_}) . q/"/␣}␣@groups;
return join(q/, /,@r) || q/""/;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some basic tests.
-
MAIN:{
say groupings q/abccccd/;
say groupings q/aaabcddddeefff/;
say groupings q/abcdd/;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl "cccc" "aaa", "dddd", "fff" ""
Part 2: Reverse Equals
You are given two arrays of integers, each containing the same elements as the other. Write a script to return true if one array can be made to equal the other by reversing exactly one contiguous subarray.
Here’s the process we’re going to follow.
- scan both arrays and check where and how often they differ
- if they differ in zero places return true!
- if they differ in one or more places check to see if the reversal makes the two arrays equal
Now let’s check and see how many differences were found.
-
return 1 if@{$indices_different} == 0;
$indices_different = [sort {$a <=> $b}@{$indices_different}];
my $last_i = $indices_different->[@{$indices_different} - 1];
my $length = 1 + $last_i - $indices_different->[0];
my@u_ = reverse@{$u}[$indices_different->[0] .. $last_i];
my@v_ = reverse@{$v}[$indices_different->[0] .. $last_i];
splice@{$u}, $indices_different->[0], $length,@u_;
splice@{$v}, $indices_different->[0], $length,@v_;
return 1 if join(q/,/,@{$u}) eq join(q/,/,@{$t});
return 1 if join(q/,/,@{$v}) eq join(q/,/,@{$s});
return 0;
◇
The rest of the code combines the previous steps and drives some tests.
-
MAIN:{
say reverse_equals [3, 2, 1, 4], [1, 2, 3, 4];
say reverse_equals [1, 3, 4], [4, 1, 3];
say reverse_equals [2], [2];
}
◇
-
Fragment referenced in 7.
Sample Run
$ perl perl/ch-2.pl 1 0 1
References
posted at: 19:21 by: Adam Russell | path: /perl | permanent link to this entry
2025-04-19
The Weekly Challenge 317 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Acronyms
You are given an array of words and a word. Write a script to return true if concatenating the first letter of each word in the given array matches the given word, return false otherwise.
We can do this in a single predicate which uses maplist to get the first character from each word, which we’ll take as a list of character code lists.
-
acronym(Words, Word):-
maplist(nth(1), Words, FirstLetters),
Word = FirstLetters.
◇
-
Fragment referenced in 2.
The rest of the code just wraps this single predicate into a file.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- acronym(["Perl", "Weekly", "Challenge"], "PWC"). yes | ?- acronym(["Bob", "Charlie", "Joe"], "BCJ"). yes | ?- acronym(["Morning", "Good"], "MM"). no | ?-
Part 2: Friendly Strings
You are given two strings. Write a script to return true if swapping any two letters in one string match the other string, return false otherwise.
This is going to be a quick one. First we will check that we can subtract/3 the two words (character code lists) and obtain an empty list. Then we’ll check in which places the words differ. They must only differ in exactly two places.
-
friendly(Word1, Word2):-
subtract(Word1, Word2, []),
length(Word1, Length),
findall(Difference, (
between(1, Length, I),
nth(I, Word1, C1),
nth(I, Word2, C2),
\+ C1 = C2,
Difference = [C1, C2]
), Differences),
length(Differences, NumberDifferences),
NumberDifferences == 2.
◇
-
Fragment referenced in 4.
Finally, let’s assemble our completed code into a single file.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- friendly("desc", "dsec"). yes | ?- friendly("cat", "dog"). no | ?- friendly("stripe", "sprite"). yes | ?-
References
posted at: 21:39 by: Adam Russell | path: /prolog | permanent link to this entry
2025-04-17
Acronyms Among Friends
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Acronyms
You are given an array of words and a word. Write a script to return true if concatenating the first letter of each word in the given array matches the given word, return false otherwise.
Here’s our one subroutine, this problem requires very little code.
-
sub acronyms{
my($word_list, $word) =@_;
my@first_letters = map{
(split //, $_)[0]
}@{$word_list};
return 1 if $word eq join q//,@first_letters;
return 0;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say acronyms([qw/Perl Weekly Challenge/], q/PWC/);
say acronyms([qw/Bob Charlie Joe/], q/BCJ/);
say acronyms([qw/Morning Good/], q/MM/);
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 1 1 0
Part 2: Friendly Strings
You are given two strings. Write a script to return true if swapping any two letters in one string match the other string, return false otherwise.
Here’s the process we’re going to follow.
- scan both words and check where and how often they differ
- if they differ in zero places return true!
- if they differ in one place or more than two places return false
- if they differ in two places and the two pairs of letters are the same return true
Now let’s check and see how many differences were found.
The rest of the code combines the previous steps and drives some tests.
-
MAIN:{
say friendly q/desc/, q/dsec/;
say friendly q/cat/, q/dog/;
say friendly q/stripe/, q/sprite/;
}
◇
-
Fragment referenced in 7.
Sample Run
$ perl perl/ch-2.pl 1 0 1
References
posted at: 20:08 by: Adam Russell | path: /perl | permanent link to this entry
2025-04-12
The Weekly Challenge 316 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Circular
You are given a list of words. Write a script to find out whether the last character of each word is the first character of the following word.
We can do this in a single predicate which recursively examines the list of words, which we’ll take as a list of character code lists.
-
circular([]).
circular([_]).
circular([H0, H1|T]):-
last(H0, C0),
nth(1, H1, C1),
C0 = C1,
circular([H1|T]).
◇
-
Fragment referenced in 2.
The rest of the code just wraps this predicate into a file.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- circular(["perl", "loves", "scala"]). true ? (1 ms) yes | ?- circular(["love", "the", "programming"]). no | ?- circular(["java", "awk", "kotlin", "node.js"]). true ? yes | ?-
Part 2: Subsequence
You are given two strings. Write a script to find out if one string is a subsequence of another.
This is going to be a quick one, seeing as GNU Prolog has a sublist/2 predicate which does exactly this! As in the previous part we’ll take the strings as lists of character codes.
Finally, let’s assemble our completed code into a single file.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- subsequence("uvw", "bcudvew"). true ? yes | ?- subsequence("aec", "abcde"). no | ?- subsequence("sip", "javascript"). true ? yes | ?-
References
posted at: 23:32 by: Adam Russell | path: /prolog | permanent link to this entry
Going Around in Sequential Circles
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Circular
You are given a list of words. Write a script to find out whether the last character of each word is the first character of the following word.
This seems straightforward enough. One question is whether we need to only consider the words in their given order. We’ll assume so.
Here’s our one subroutine, this problem requires very little code.
-
sub circular{
my $current = shift@_;
my $current_last = (split //, $current)[length($current) - 1];
do{
my $previous_last = $current_last;
$current = $_;
my $current_first = (split //, $current)[0];
$current_last = (split //, $current)[length($current) - 1];
return 0 if $previous_last ne $current_first;
} for@_;
return 1;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say circular(qw/perl loves scala/);
say circular(qw/love the programming/);
say circular(qw/java awk kotlin node.js/);
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 1 0 1
Part 2: Subsequence
You are given two strings. Write a script to find out if one string is a subsequence of another.
A subsequence of a string is a new string that is formed from the original string by deleting some (can be none) of the characters without disturbing the relative positions of the remaining characters.
We’re going to do this in teh shortest way possible, via a regular expression.
We’re going to construct the regular expression dynamically each time
The shorter of the two strings will be what we test as the potential subsequence of the other longer one.
We’re going to have the work done in a single subroutine which determines which string to test, builds the regex, and runs it.
The rest of the code drives some tests.
-
MAIN:{
say subsequence q/uvw/, q/bcudvew/;
say subsequence q/aec/, q/abcde/;
say subsequence q/sip/, q/javascript/;
}
◇
-
Fragment referenced in 8.
Sample Run
$ perl perl/ch-2.pl 1 0 1
References
posted at: 22:58 by: Adam Russell | path: /perl | permanent link to this entry
2025-04-06
The Weekly Challenge 315 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Find Words
You are given a list of words and a character. Write a script to return the index of word in the list where you find the given character.
This can be done with a basic predicate with findall. Or we can use maplist! maplist is more fun in my opinion, so we’ll go with that.
First off a small utility predicate to see if a word contains a given letter.
-
contains_letter(Letter, Index-Word, Index):-
atom_chars(Word, C),
member(Letter, C).
contains_letter(_, _, -1).
◇
-
Fragment referenced in 4.
You can see that we are sending that previous predicate a pair. The first element in that pair is an index. Let’s build a word index, mainly for the sake of avoiding the use of between and findall. Those builtin predicates are fine, but aesthetically to me it seems nicer to not use them if we absolutely don’t have to.
-
word_index(Words, Index):-
word_index(Words, 0, Index).
word_index([], _, []).
word_index([H|T], N, [I-H|Index]):-
succ(N, I),
word_index(T, I, Index).
◇
-
Fragment referenced in 4.
Now we’ll use maplist to find the words.
-
find_words(Words, Letter, Indices):-
word_index(Words, Index),
maplist(contains_letter(Letter), Index, I),
delete(I, -1, Indices).
◇
-
Fragment referenced in 4.
The rest of the code just wraps this predicate into a file.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- find_words([the, weekly, challenge], e, Indices). Indices = [1,2,3] ? yes | ?- find_words([perl, raku, python], p, Indices). Indices = [1,3] ? yes | ?- find_words([abc, def, bbb, bcd], b, Indices). Indices = [1,3,4] ? yes | ?-
Part 2: Find Third
You are given a sentence and two words. Write a script to return all words in the given sentence that appear in sequence to the given two words.
In the first part I mentioned the between and findall predicates. Here we will use them to find successive words.
-
find_third(Words, One, Two, Thirds):-
length(Words, WordLength),
N is WordLength - 2,
findall(Third, (
between(1, N, I),
succ(I, J),
nth(I, Words, One),
nth(J, Words, Two),
succ(J, K),
nth(K, Words, Third)
), Thirds).
◇
-
Fragment referenced in 6.
Finally, let’s assemble our completed code into a single file.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- find_third([’Perl’, is, a, my, favourite, language, but, ’Python’, is, my, favourite, too], my, favourite, Thirds). Thirds = [language,too] yes | ?- find_third([’Barbie’, is, a, beautiful, doll, also, also, a, beautiful, princess], a, beautiful, Thirds). Thirds = [doll,princess] yes | ?- find_third([we, will, we, will, rock, you, rock, you], we, will, Thirds). Thirds = [we,rock] yes | ?-
References
posted at: 17:41 by: Adam Russell | path: /prolog | permanent link to this entry
Finding a Third of the Words
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Find Words
You are given a list of words and a character. Write a script to return the index of word in the list where you find the given character.
This can be done in essentially one line. Rather than write a true Perl one-liner for the command line though, we’ll package this into a single subroutine.
Here’s our one subroutine.
-
sub find_words{
my($s, $c) =@_;
return grep {$s->[$_] =~ m/$c/} 0 ..@{$s} - 1;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say q/(/ . join(q/, /, find_words([q/the/, q/weekly/, q/challenge/], q/e/)). q/)/;
say q/(/ . join(q/, /, find_words([q/perl/, q/raku/, q/python/], q/p/)) . q/)/;
say q/(/ . join(q/, /, find_words([q/abc/, q/def/, q/bbb/, q/bcd/], q/b/)) . q/)/;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl (0, 1, 2) (0, 2) (0, 2, 3)
Part 2: Find Third
You are given a sentence and two words. Write a script to return all words in the given sentence that appear in sequence to the given two words.
Similar to the first part this will be a single short subroutine. We’re just going to loop over the words and match as we go. There are two small things to note here: we strip out any punctuation from our sentence and the empty string q// is considered by Perl to be a false value. The latter is only important in that is how we initialize $next.
-
sub find_third{
my ($s, $first, $second) =@_;
$s =~ s/[[:punct:]]//g;
my@thirds = ();
my($previous, $current, $next) = (q//, q//, q//);
do{
push@thirds, $_ if $next;
$current = $_;
$next = 1 if $previous eq $first && $current eq $second;
$next = 0 unless $previous eq $first && $current eq $second;
$previous = $current;
} for split q/\s+/, $s;
return@thirds;
}
◇
-
Fragment referenced in 6.
The rest of the code drives some tests.
-
MAIN:{
say q/(/ . join(q/, /, find_third(q/Perl is a my favourite language but Python is my favourite too./, q/my/, q/favourite/)). q/)/;
say q/(/ . join(q/, /, find_third(q/Barbie is a beautiful doll also also a beautiful princess./, q/a/, q/beautiful/)) . q/)/;
say q/(/ . join(q/, /, find_third(q/we will we will rock you rock you./, q/we/, q/will/)) . q/)/;
}
◇
-
Fragment referenced in 6.
Sample Run
$ perl perl/ch-2.pl (language, too) (doll, princess) (we, rock)
References
posted at: 17:29 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-29
The Weekly Challenge 314 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Equal Strings
You are given three strings. You are allowed to remove the rightmost character of a string to make all equals. Write a script to return the number of operations to make it equal otherwise -1.
The approach we’ll take is to pop off the last letter of each and compare the remainders. If they are equal then we are done. Otherwise we’ll continue popping off letter until we’re done.
A special case to consider is when the strings are of unequal length. In that case we make sure to only pop off letters from equal length strings, although the untouched strings will still be used when checking to see if we are done.
We’re going to define some convenience predicates, some with the intention that they’re going to be called from a maplist.
-
remove_last(S, S1):-
length(Last, 1),
append(S1, Last, S).
◇
-
Fragment referenced in 7.
-
match_length(Length, S, S):-
length(S, Length).
match_length(_, _, nil).
◇
-
Fragment referenced in 7.
-
max_string_size(Strings, MaxLength):-
maplist(length, Strings, Lengths),
max_list(Lengths, MaxLength).
◇
-
Fragment referenced in 7.
We’ll define a predicate for doing all the co-ordination and overall logic.
-
equal_strings(Strings, Operations):-
equal_strings(Strings, 0, Operations), !.
equal_strings(Strings, Operations, Operations):-
last(Strings, S),
\+ S = [],
all_equal(Strings).
equal_strings(Strings, _, -1):-
last(Strings, S),
S = [].
equal_strings(Strings, OperationsAccum, Operations):-
max_string_size(Strings, MaxLength),
maplist(match_length(MaxLength), Strings, S1),
delete(S1, nil, S2),
subtract(Strings, S2, S4),
maplist(remove_last, S2, S3),
append(S4, S3, S5),
all_equal(S5),
\+ all_empty(S5),
length(S2, Removals),
Operations is OperationsAccum + Removals.
equal_strings(Strings, OperationsAccum, Operations):-
max_string_size(Strings, MaxLength),
maplist(match_length(MaxLength), Strings, S1),
delete(S1, nil, S2),
subtract(Strings, S2, S4),
maplist(remove_last, S2, S3),
append(S4, S3, S5),
\+ all_equal(S5),
length(S2, Removals),
O is OperationsAccum + Removals,
equal_strings(S5, O, Operations).
◇
-
Fragment referenced in 7.
The rest of the code just wraps this predicate into a file.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- equal_strings(["abb", "ab", "abc"], Operations). Operations = 2 yes | ?- equal_strings(["ayz", "cyz", "xyz"], Operations). Operations = -1 yes | ?- equal_strings(["yza", "yzb", "yzc"], Operations). Operations = 3 yes | ?-
Part 2: Sort Column
You are given a list of strings of same length. Write a script to make each column sorted lexicographically by deleting any non sorted columns. Return the total columns deleted.
We’ll start with a short predicate for convenience.
-
sort_column(Strings, Removals):-
last(Strings, S),
length(S, L),
findall(R, (
between(1, L, I),
column(I, Strings, Column),
msort(Column, ColumnSorted),
\+ Column == ColumnSorted,
R = Column
), Rs),
length(Rs, Removals).
◇
-
Fragment referenced in 10.
Finally, let’s assemble our completed code into a single file.
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- sort_column(["swpc", "tyad", "azbe"], Removals). Removals = 2 yes | ?- sort_column(["cba", "daf", "ghi"], Removals). Removals = 1 yes | ?- sort_column(["a", "b", "c"], Removals). Removals = 0 yes | ?-
References
posted at: 19:05 by: Adam Russell | path: /prolog | permanent link to this entry
2025-03-27
Equally Sorted
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Equal Strings
You are given three strings. You are allowed to remove the rightmost character of a string to make all equals. Write a script to return the number of operations to make it equal otherwise -1.
The fact that we’re give exactly three strings makes things slightly easier. The approach we’ll take is to pop off the last letter of each and compare the remainders. If they are equal then we are done. Otherwise we’ll continue popping off letter until we’re done.
A special case to consider is when the strings are of unequal length. In that case we make sure to only pop off letters from equal length strings, although the untouched strings will still be used when checking to see if we are done.
Everything can be easily contained in one subroutine. I know that the do blocks with postfix if are not common, but to me they are the most aesthetic way to conditionally perform two short statements.
-
sub loop_pop_compare{
my($s, $t, $u) =@_;
my@s = split //, $s;
my@t = split //, $t;
my@u = split //, $u;
my $counter = 0;
{
my $max_size = (sort {$b <=> $a} (0 +@s, 0 +@t, 0 +@u))[0];
unless(join(q//,@s) eq join(q//,@t) &&
join(q//,@t) eq join(q//,@u)){
do{$counter++; pop@s} if@s == $max_size;
do{$counter++; pop@t} if@t == $max_size;
do{$counter++; pop@u} if@u == $max_size;
}
else{
return $counter;
}
redo unless@s == 0 ||@t == 0 ||@u == 0;
}
return -1;
}
◇
-
Fragment referenced in 2.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say loop_pop_compare q/abc/, q/abb/, q/ab/;
say loop_pop_compare q/ayz/, q/cyz/, q/xyz/;
say loop_pop_compare q/yza/, q/yzb/, q/yzc/;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 2 -1 3
Part 2: Sort Column
You are given a list of strings of same length. Write a script to make each column sorted lexicographically by deleting any non sorted columns. Return the total columns deleted.
Unlike the first part, the strings here are guaranteed to be all of the same length and we do not know how many we will need to consider.
-
my $remaining = [grep {$string->[$_] if $_ != $i} 0 ..@{$string} - 1];
◇
-
Fragment never referenced.
-
Defines:
$remainingNever used. -
Uses:
$i8.
We’ll put everything together in a single subroutine.
The rest of the code drives some tests.
-
MAIN:{
say sort_columns qw/swpc tyad azbe/;
say sort_columns qw/cba daf ghi/;
say sort_columns qw/a b c/;
}
◇
-
Fragment referenced in 9.
Sample Run
$ perl perl/ch-2.pl 2 1 0
References
posted at: 18:14 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-23
Reverse Broken Keys for Letters
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Broken Keys
You have a broken keyboard which sometimes type a character more than once. You are given a string and actual typed string. Write a script to find out if the actual typed string is meant for the given string.
What we’re faced with here is a problem of removing consecutive duplicated letters. The trick is that some letters may be correctly duplicated in succession! For example “coffeescript”has two f’s and two e’s which are not in error. We’re given the correct version so wee need to track the current correct letter and find deviations.
Another special case to consider is when the deviations occur at the end of the string and we get all of the same repeated letters as in the “rrakuuuu”example. To address this we check if the repeated letters remaining match the last known good letter.
Our solution is to loop over the letters in the candidate string guided by the original word. We do this all in one subroutine, the code is not so unwieldy to need to be broken into smaller pieces.
-
sub loop_compare{
my($n, $s) =@_;
my@n = split //, $n;
my@s = split //, $s;
my $current_n = q//;
my $current_s = q//;
{
my $previous_n = $current_n;
$current_n = shift@n;
$current_s = shift@s;
if($current_s ne $current_n && $current_s eq $previous_n){
unshift@n, $current_n;
{
$current_s = shift@s;
redo if $current_s eq $previous_n &&@s > 0;
unshift@s, $current_s;
}
}
return 0 if $current_s ne $current_n && $current_s ne $previous_n;
redo if@n > 0 &&@s > 0;
}
return 1 if (@n == 0 &&@s ==0) || (@s == grep {$_ eq $current_s}@s);
return 0;
}
◇
-
Fragment referenced in 2.
We really just need one subroutine to co-ordinate the inputs and run the main loop that’s required.
Putting it all together...
The rest of the code just runs some simple tests.
-
MAIN:{
say loop_compare q/perl/, q/perrrl/;
say loop_compare q/raku/, q/rrakuuuu/;
say loop_compare q/python/, q/perl/;
say loop_compare q/coffeescript/, q/cofffeescccript/;
}
◇
-
Fragment referenced in 2.
Sample Run
$ perl perl/ch-1.pl 1 1 0 1
Part 2: Reverse Letters
You are given a string. Write a script to reverse only the alphabetic characters in the string.
First we separate the alphabetic characters from the string, then we reverse them, then we finish by recombining the reversed alphabetic characters with the non-alphabetic characters.
We’ll put everything together in a single subroutine.
The rest of the code drives some tests.
-
MAIN:{
say reverse_letters q/p-er?l/;
say reverse_letters q/wee-k!L-y/;
say reverse_letters q/_c-!h_all-en!g_e/;
}
◇
-
Fragment referenced in 9.
Sample Run
$ perl perl/ch-2.pl l-re?p yLk-e!e-w _e-!g_nel-la!h_c
References
posted at: 14:18 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-16
The Weekly Challenge 312 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Minimum Time
You are given a typewriter with lowercase english letters a to z arranged in a circle. Typing a character takes 1 sec. You can move pointer one character clockwise or anti-clockwise. The pointer initially points at a. Write a script to return minimum time it takes to print the given string.
All the logic for computing the shortest move us contained in a single predicate.
-
compute_moves(Current, Next, Moves):-
X is Current - 96,
Y is Next - 96,
XH is X + 13,
YH is Y + 13,
((Y >= XH, Moves is X + 26 - Y);
(Y >= X, Y =< XH, Moves is Y - X);
(X >= YH, Moves is Y + 26 - X);
(X >= Y, X =< YH, Moves is X - Y)).
◇
-
Fragment referenced in 3.
We’ll use a DCG to process the list of letters (we’re using ASCII codes).
-
minimum_time([Current, Next|Letters]) --> [Time], {
compute_moves(Current, Next, Moves),
succ(Moves, Time)}, minimum_time([Next|Letters]).
minimum_time([_]) --> [].
◇
-
Fragment referenced in 3.
Finally, let’s combine the previous predicates into a file along with a predicate minimum_time/2 that ties everything together.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- minimum_time("abc", MinimumTime). MinimumTime = 5 yes | ?- minimum_time("bza", MinimumTime). MinimumTime = 7 yes | ?- minimum_time("zjpc", MinimumTime). MinimumTime = 34 yes | ?-
Part 2: Balls and Boxes
There are $n balls of mixed colors: red, blue or green. They are all distributed in 10 boxes labelled 0-9. You are given a string describing the location of balls. Write a script to find the number of boxes containing all three colors. Return 0 if none found.
We’ll use a DCG here in Part 2, althought it’ll be just a little bit more intricate.
First off, we’ll be passing the state around via some helper predicates. At the end of processing we’ll have a set of pairs that hold the contents of each box.
-
boxes(Boxes), [Boxes] --> [Boxes].
boxes(Box, Boxes), [Boxes] --> [Box].
◇
-
Fragment referenced in 7.
Now the DCG. For each record given we’ll process each Ball/Box pair.
-
box_record([]) --> [].
box_record(Record) --> boxes(B, Boxes), {[Color, Box|T] = Record,
var(B), B = Box-[Color], append([], [B], Boxes)},
box_record(T).
box_record(Record) --> boxes(B, Boxes), {[Color, Box|T] = Record,
nonvar(B), member(Box-Colors, B), delete(B, Box-Colors, B0),
append([Color], Colors, Colors0), append([Box-Colors0], B0, Boxes)},
box_record(T).
box_record(Record) --> boxes(B, Boxes), {[Color, Box|T] = Record,
nonvar(B), \+ member(Box-_, B), append([Box-[Color]], B, Boxes)},
box_record(T).
◇
-
Fragment referenced in 7.
-
full_box(_-Colors, Full):-
sort(Colors, ColorsSorted),
length(ColorsSorted, NumberColors),
((NumberColors == 3, Full = true);
(Full = false)).
◇
-
Fragment referenced in 7.
Finally, let’s assemble our completed code into a single file. We’ll also add a predicate to co-orindate calling the DCG and processing the final result.
"ch-2.p" 7≡
-
full_boxes(BallsBoxes, CountFullBoxes):-
phrase(box_record(BallsBoxes), [_], [Boxes]),
maplist(full_box, Boxes, Full),
delete(Full, false, FullBoxes),
length(FullBoxes, CountFullBoxes), !.
◇
Sample Run
$ gprolog --consult-file prolog/ch-2.p | ?- full_boxes("G0B1R2R0B0", FullBoxes). FullBoxes = 1 yes | ?- full_boxes("G1R3R6B3G6B1B6R1G3", FullBoxes). FullBoxes = 3 yes | ?- full_boxes("B3B2G1B3", FullBoxes). FullBoxes = 0 yes | ?-
References
posted at: 15:35 by: Adam Russell | path: /prolog | permanent link to this entry
Minimum Time in the Box
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Minimum Time
You are given a typewriter with lowercase english letters a to z arranged in a circle. Typing a character takes 1 sec. You can move pointer one character clockwise or anti-clockwise. The pointer initially points at a. Write a script to return minimum time it takes to print the given string.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
All the work is in one subroutine. We use the ASCII values of each character to compute the new value.
-
sub minimum_time{
my($s) =@_;
my@c = split //, lc($s);
my $time = 0;
my $moves;
my $current = q/a/;
{
my $next = shift@c;
my($x, $y) = (ord($current) - 96, ord($next) - 96);
$moves = ($x + 26) - $y if $y >= ($x + 13);
$moves = $y - $x if $y <= ($x + 13) && $y >= $x;
$moves = ($y + 26) - $x if $x >= ($y + 13);
$moves = $x - $y if $x <= ($y + 13) && $x >= $y;
$time += $moves;
$time++;
$current = $next;
redo if@c > 0;
}
return $time;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say minimum_time q/abc/;
say minimum_time q/bza/;
say minimum_time q/zjpc/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 5 7 34
Part 2: Balls and Boxes
There are $n balls of mixed colors: red, blue or green. They are all distributed in 10 boxes labelled 0-9. You are given a string describing the location of balls. Write a script to find the number of boxes containing all three colors. Return 0 if none found.
We’re going to use Parse::Yapp for this problem. Writing parsers is fun! This problem is providing an excuse to write one. This approach has been used in past weeks, for example TWC 259 from this time last year. For simplicity, to start with, here is all the code that Parse::Yapp will use as it’s input.
"ch-2.yp" 5≡
-
%token LETTER
%token NUMBER
%{
my %boxes = ();
%}
%%
records: record {\%boxes}
| records record
;
record: LETTER NUMBER {push@{$boxes{qq/$_[2]/}}, $_[1]}
;
%%
sub lexer{
my($parser) =@_;
defined($parser->YYData->{INPUT}) or return(’’, undef);
##
# send tokens to parser
##
for($parser->YYData->{INPUT}){
s/^([0-9])// and return (q/NUMBER/, $1);
s/^([A-Z])// and return (q/LETTER/, $1);
}
}
sub error{
exists $_[0]->YYData->{ERRMSG}
and do{
print $_[0]->YYData->{ERRMSG};
return;
};
print "syntax␣error\n";
}
sub parse{
my($self, $input) =@_;
$input =~ tr/\t/ /s;
$input =~ tr/ //s;
$self->YYData->{INPUT} = $input;
my $result = $self->YYParse(yylex => \&lexer, yyerror => \&error);
return $result;
}
◇
To solve this problem we are going to pass the input string to the parser. The parser is going to return a hash reference which we’ll check to see which boxes contain all the balls, as described in the problem statement.
-
sub parse_boxes{
my($record) =@_;
my $parser = Ch2->new();
my $boxes = $parser->parse($record);
my $full = 0;
for my $box (keys %{$boxes}){
$full++ if 1 <= (grep { $_ eq q/R/ }@{$boxes->{$box}}) &&
1 <= (grep { $_ eq q/G/ }@{$boxes->{$box}}) &&
1 <= (grep { $_ eq q/B/ }@{$boxes->{$box}});
}
return $full;
}
◇
-
Fragment referenced in 6.
Finally, we need to confirm everything is working right.
Sample Run
$ yapp -m Ch2 perl/ch-2.yp; mv Ch2.pm perl $ perl -I perl perl/ch-2.pl G0B1R2R0B0 1 $ perl -I perl perl/ch-2.pl G1R3R6B3G6B1B6R1G3 3 $ perl -I perl perl/ch-2.pl B3B2G1B3 0
References
posted at: 01:29 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-09
The Weekly Challenge 311 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Upper Lower
You are given a string consists of english letters only. Write a script to convert lower case to upper and upper case to lower in the given string.
GNU Prolog defines a predicate lower_upper/2 which does pretty much what this problem is asking for. We could also just use the character code values instead of chars, but using chars seems a little more elegant as it avoids ASCII math.
-
upper_lower(S, UpperLower):-
atom_chars(S, C),
upper_lower(C, UL, _),
atom_chars(UpperLower, UL).
upper_lower([], [], _).
upper_lower([C|T], [L|UL], _):-
lower_upper(C, C0),
C == C0,
lower_upper(L, C),
upper_lower(T, UL, _).
upper_lower([C|T], [U|UL], _):-
lower_upper(C, U),
\+ C == U,
upper_lower(T, UL, _).
◇
-
Fragment referenced in 2.
The rest of the code just wraps this predicate into a file.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- upper_lower(’pERl’, UpperLower). UpperLower = ’PerL’ ? yes | ?- upper_lower(’rakU’, UpperLower). UpperLower = ’RAKu’ ? yes | ?- upper_lower(’PyThOn’, UpperLower). UpperLower = pYtHoN ? yes | ?-
Part 2: Group Digit Sum
You are given a string, $str, made up of digits, and an integer, $int, which is less than the length of the given string. Write a script to divide the given string into consecutive groups of size $int (plus one for leftovers if any). Then sum the digits of each group, and concatenate all group sums to create a new string. If the length of the new string is less than or equal to the given integer then return the new string, otherwise continue the process.
To solve this problem we need to do the following
- divide the list into groups of the given size
- compute the sums
- recombine
- repeat as needed
Let’s look at each of those pieces individually and then combine them together into one predicate.
-
group_list(S, Size, GroupedList):-
atom_chars(S, C),
maplist(char_number, C, N),
group_list(N, Size, [], [], GroupedList).
group_list([], _, Group, GroupedListAccum, GroupedList):-
length(Group, L),
((L > 0, append(GroupedListAccum, [Group], GroupedList));
(GroupedList = GroupedListAccum)).
group_list([H|T], Size, Group, GroupedListAccum, GroupedList):-
length(Group, L),
L < Size,
append(Group, [H], G),
GLA = GroupedListAccum,
group_list(T, Size, G, GLA, GroupedList).
group_list([H|T], Size, Group, GroupedListAccum, GroupedList):-
length(Group, L),
L == Size,
append(GroupedListAccum, [Group], GLA),
group_list([H|T], Size, [], GLA, GroupedList).
◇
-
char_number(C, N):-
number_chars(N, [C]).
◇
-
Fragment referenced in 9.
We can compute the sums using the GNU Prolog builtin predicate sum_list/2.
-
join([], ’’).
join([H|T], A):-
join(T, A0),
number_atom(H, A1),
atom_concat(A1, A0, A).
◇
-
Fragment referenced in 9.
Finally, let’s assemble our completed code into a single file.
Sample Run
$ gprolog prolog/ch-2.p | ?- group_digit_sum(’111122333’, 3, GroupDigitSum). GroupDigitSum = ’359’ yes | ?- group_digit_sum(’1222312’, 2, GroupDigitSum). GroupDigitSum = ’76’ yes | ?- group_digit_sum(’100012121001’, 4, GroupDigitSum). GroupDigitSum = ’162’ yes | ?-
References
posted at: 00:39 by: Adam Russell | path: /prolog | permanent link to this entry
2025-03-08
Lower the Upper Sums!
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Upper Lower
You are given a string consists of english letters only. Write a script to convert lower case to upper and upper case to lower in the given string.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
All the work is in one subroutine. We use the ASCII values of each character to compute the new value.
-
sub upper_lower{
my($s) =@_;
my@c = split //, $s;
return join q//, map{
my $x = ord($_);
if($x >= 65 && $x <= 90){
chr($x + 32);
}
elsif($x >= 97 && $x <= 122){
chr($x - 32);
}
}@c;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say upper_lower q/pERl/;
say upper_lower q/rakU/;
say upper_lower q/PyThOn/;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl PerL RAKu pYtHoN
Part 2: Group Digit Sum
You are given a string, $str, made up of digits, and an integer, $int, which is less than the length of the given string. Write a script to divide the given string into consecutive groups of size $int (plus one for leftovers if any). Then sum the digits of each group, and concatenate all group sums to create a new string. If the length of the new string is less than or equal to the given integer then return the new string, otherwise continue the process.
To solve this problem we need to do the following
- 1.
- divide the list into groups of the given size
- 2.
- compute the sums
- 3.
- recombine
- 4.
- repeat as needed
Let’s look at each of those pieces individually and then combine them together into one subroutine.
-
my $g = [];
my $groups;
for my $i (0 ..@{$c} - 1){
my $n = $i % $size;
if($n == 0){
$g = [];
push@{$g}, $c->[$i];
}
elsif($n == $size - 1){
push@{$g}, $c->[$i];
push@{$groups}, $g;
$g = [];
}
else{
push@{$g}, $c->[$i];
}
}
push@{$groups}, $g if@{$g} > 0;
◇
With that work take care of, let’s combine all these pieces into one subroutine.
Finally, here’s a few tests to confirm everything is working right.
-
MAIN:{
say group_digit_sum q/111122333/, 3;
say group_digit_sum q/1222312/, 2;
say group_digit_sum q/100012121001/, 4;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl perl/ch-2.pl 359 76 162
References
posted at: 22:30 by: Adam Russell | path: /perl | permanent link to this entry
2025-03-02
The Weekly Challenge 310 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Arrays Intersection
You are given a list of array of integers. Write a script to return the common elements in all the arrays.
Let’s define a predicate that can be called via maplist. This will just wrap member and be used to return a list of common elements. We’ll also remove duplicates (via sort).
Note that because the predicate used with maplist must be true for all list elements we’ll return a nil value if there is no match. We just need to make sure to delete all the nils before further using the list.
-
common_elements(L0, L1, Common):-
maplist(common_element(L0), L1, C0),
sort(C0, C1),
delete(C1, nil, Common).
common_element(L, X, X):-
member(X, L).
common_element(L, X, nil):-
\+ member(X, L).
◇
-
Fragment referenced in 3.
The plan is to find the common elements in the first two lists and then compare those common elements against the rest of the lists, only keeping elements that continue to be in common. We’ll use tail recursion and an accumulator here.
-
intersections(Lists, Intersections):-
intersections(Lists, [], Intersections).
intersections([H0, H1|[]], [], Intersections):-
common_elements(H0, H1, Intersections).
intersections([H0, H1|[]], IntersectionsAccum, Intersections):-
common_elements(H0, H1, Common),
common_elements(Common, IntersectionsAccum, Intersections).
intersections([H0, H1|T], IntersectionsAccum, Intersections):-
common_elements(H0, H1, Common),
append(IntersectionsAccum, Common, I),
intersections([Common|T], I, Intersections).
◇
-
Fragment referenced in 3.
The rest of the code just wraps this predicate into a file.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- intersections([[1, 2, 3, 4], [4, 5, 6, 1], [4, 2, 1, 3]], Intersections). Intersections = [1,4] ? yes | ?- intersections([[1, 0, 2, 3], [2, 4, 5]], Intersections). Intersections = [2] ? yes | ?- intersections([[1, 2, 3], [4, 5], [6]], Intersections). Intersections = [] ? yes | ?-
Part 2: Sort Odd Even
You are given an array of integers. Write a script to sort odd index elements in decreasing order and even index elements in increasing order in the given array.
To solve this problem we need to do the following
- seperate the odd and even indexed numbers
- sort the two lists as directed
- combine the results
This problem was written with 0-based indices in mind so we will keep that in mind when calculating whether an index is odd or even.
-
odd_even_indexed(List, Odds, Evens):-
length(List, L),
findall(Odd,(
between(1, L, Index),
succ(I, Index),
M is I rem 2,
\+ M == 0,
nth(Index, List, Odd)
), Odds),
findall(Even,(
between(1, L, Index),
succ(I, Index),
M is I rem 2,
M == 0,
nth(Index, List, Even)
), Evens).
◇
-
Fragment referenced in 8.
We’ll need a few more predicates to contain most of the rest of the work needed. To do the descending sort we’ll take the negatives of the numbers. We also need to combine the final result.
-
combine(OddsSorted, EvensSorted, Combined):-
combine(OddsSorted, EvensSorted, 0, [], Combined).
combine([], [], _, Combined, Combined).
combine([O|OT], EvensSorted, Index, CombinedAccum, Combined):-
M is Index rem 2,
\+ M == 0,
append(CombinedAccum, [O], C),
succ(Index, I),
combine(OT, EvensSorted, I, C, Combined).
combine(OddsSorted, [E|ET], Index, CombinedAccum, Combined):-
M is Index rem 2,
M == 0,
append(CombinedAccum, [E], C),
succ(Index, I),
combine(OddsSorted, ET, I, C, Combined).
◇
-
Fragment referenced in 8.
-
sort_odd_evens(List, Sorted):-
odd_even_indexed(List, Odds, Evens),
maplist(negate, Odds, OddsNegated),
sort(OddsNegated, OddsNegatedSorted),
maplist(negate, OddsNegatedSorted, OddsSorted),
sort(Evens, EvensSorted),
combine(OddsSorted, EvensSorted, Sorted).
◇
-
Fragment referenced in 8.
Finally, let’s assemble our completed code into a single file.
Sample Run
$ gprolog prolog/ch-2.p | ?- sort_odd_evens([4, 1, 2, 3], Sorted). Sorted = [2,3,4,1] ? yes | ?- sort_odd_evens([3, 1], Sorted). Sorted = [3,1] ? yes | ?- sort_odd_evens([5, 3, 2, 1, 4], Sorted). Sorted = [2,3,4,1,5] ? yes | ?-
References
posted at: 23:09 by: Adam Russell | path: /prolog | permanent link to this entry
2025-03-01
Arrays Intersect in Odd Ways
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Arrays Intersection
You are given a list of array of integers. Write a script to return the common elements in all the arrays.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
We’ll take the arrays in pairs and build up a list of common elements. First we compute the common elements of the first two arrays and then proceed to check these against the remaining arrays. If any of these initial common elements are not found in subsequent arrays they are not included in future checks. Finally the remaining common elements are returned. If there are no common elements we return n/a.
-
sub array_intersections{
my@common_elements;
my $x = shift@_;
my $y = shift@_;
if($x && $y){
my@common = map {
my $x = $_;
grep {$x == $_}@{$y}
}@{$x};
push@common_elements,@common;
}
{
$x = shift@_;
my@common = map {
my $x = $_;
grep {$x == $_}@{$y}
}@common_elements;
common_elements =@common;
redo if@_ > 1;
}
return (join q/, /,@common_elements) || q#n/a#;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say array_intersections [1, 2, 3, 4], [4, 5, 6, 1], [4, 2, 1, 3];
say array_intersections [1, 0, 2, 3], [2, 4, 5];
say array_intersections [1, 2, 3], [4, 5], [6];
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 1, 4 2 n/a
Part 2: Sort Odd Even
You are given an array of integers. Write a script to sort odd index elements in decreasing order and even index elements in increasing order in the given array.
To solve this problem we need to do the following
- 1.
- seperate the odd and even numbers
- 2.
- sort the two lists as directed
- 3.
- combine the results
Much of this work can be written concisely using map and grep.
-
sub sort_odd_even{
my@i =@_;
my@odds = map { $i[$_] } grep {$_ % 2 != 0} 0 ..@_ - 1;
my@evens = map { $i[$_] } grep {$_ % 2 == 0} 0 ..@_ - 1;
my@odds_sorted = sort {$b <=> $a}@odds;
my@evens_sorted = sort {$a <=> $b}@evens;
my@common_elements;
do {
$common_elements[$_] = shift@odds_sorted if $_ % 2 != 0;
$common_elements[$_] = shift@evens_sorted if $_ % 2 == 0;
} for 0 ..@_ - 1;
return@common_elements;
}
◇
-
Fragment referenced in 5.
Finally, here’s a few tests to confirm everything is working right.
-
MAIN:{
say join q/, /, sort_odd_even 4, 1, 2, 3;
say join q/, /, sort_odd_even 3, 1;
say join q/, /, sort_odd_even 5, 3, 2, 1, 4;
}
◇
-
Fragment referenced in 5.
Sample Run
$ perl perl/ch-2.pl 2, 3, 4, 1 3, 1 2, 3, 4, 1, 5
References
posted at: 22:17 by: Adam Russell | path: /perl | permanent link to this entry
2025-02-23
The Weekly Challenge 309 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Min Gap
You are given an array of integers, @ints, increasing order. Write a script to return the element before which you find the smallest gap.
There are probably a few good approaches to this problem. Here we’ll use a DCG approach. Ultimately this problem is at its core is to process a list of integers, and processing a list is something a DCG is well suited to handle.
We will be passing the state of the minimal gap found through the list processing predicates. The plan is that every time we find a new smallest gap the element where we found it will be appended to the list, along with the size of the gap. At the end of processing the final element will contain where the smallest gap was found.
-
min_gap([]) --> [].
min_gap(Integers) --> {[_] = Integers}.
min_gap(Integers) -->
gap(G, Gap),
{[X,Y|T] = Integers, D is Y - X, var(G), G = D, append([], [G-Y], Gap)},
min_gap([Y|T]).
min_gap(Integers) -->
gap(G, Gap),
{[X,Y|T] = Integers, D is Y - X, last(G, GCurrent-_), D < GCurrent, append(G, [D-Y], Gap)},
min_gap([Y|T]).
min_gap(Integers) -->
gap(G, Gap),
{[X,Y|T] = Integers, D is Y - X, last(G, GCurrent-_), D >= GCurrent, Gap = G},
min_gap([Y|T]).
◇
-
Fragment referenced in 4.
Let’s give this DCG a simple interface. We’ll write a utility predicate that calls the DCG and sets the location of the smallest gap found.
-
min_gap(Integers, MinGapLocation):-
phrase(min_gap(Integers), [_], [Gaps]),
last(Gaps, _-MinGapLocation), !.
◇
-
Fragment referenced in 4.
The rest of the code just wraps this predicate into a file.
Sample Run
$ gprolog --consult-file prolog/ch-1.p | ?- min_gap([2, 8, 10, 11, 15], MinGapLocation). MinGapLocation = 11 (1 ms) yes | ?- min_gap([1, 5, 6, 7, 14], MinGapLocation). MinGapLocation = 6 yes | ?- min_gap([8, 20, 25, 28], MinGapLocation). MinGapLocation = 28 yes | ?-
Part 2: Min Diff
You are given an array of integers, @ints. Write a script to find the minimum difference between any two elements.
From Part 1 we know that if we sort the list we know we need to only check adjacent elements to find the minimum difference.
Much of the code is going to be the same. In fact there’s going to be less code since all we need to do is track the gap sizes and not the locations.
-
min_gap([]) --> [].
min_gap(Integers) --> {[_] = Integers}.
min_gap(Integers) -->
gap(G, Gap),
{[X,Y|T] = Integers, D is Y - X, var(G), G = D, append([], [G], Gap)},
min_gap([Y|T]).
min_gap(Integers) -->
gap(G, Gap),
{[X,Y|T] = Integers, D is Y - X, last(G, GCurrent), D < GCurrent, append(G, [D], Gap)},
min_gap([Y|T]).
min_gap(Integers) -->
gap(G, Gap),
{[X,Y|T] = Integers, D is Y - X, last(G, GCurrent), D >= GCurrent, Gap = G},
min_gap([Y|T]).
◇
-
Fragment referenced in 7.
As before let’s give this DCG a simple interface. We’ll write a utility predicate that calls the DCG and sets the smallest gap found.
-
min_gap(Integers, MinGap):-
msort(Integers, SortedIntegers),
phrase(min_gap(SortedIntegers), [_], [Gaps]),
last(Gaps, MinGap), !.
◇
-
Fragment referenced in 7.
Finally, let’s assemble our completed code into a single file.
Sample Run
$ gprolog prolog/ch-2.p | ?- min_gap([1, 5, 8, 9], MinGap). MinGap = 1 yes | ?- min_gap([9, 4, 1, 7], MinGap). MinGap = 2 yes | ?-
References
posted at: 20:01 by: Adam Russell | path: /prolog | permanent link to this entry
Gap Minimizations
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1: Min Gap
You are given an array of integers, @ints, increasing order. Write a script to return the element before which you find the smallest gap.
The complete solution is contained in one file that has a simple structure.
For this problem we do not need to include very much. We’re just specifying to use the current version of Perl, for all the latest features in the language. This fragment is also used in Part 2.
Let’s not even store anything. Instead go down the list and update two variables: one to store the current minimum gap, and the other to store the element before the current smallest gap found.
I use a small trick here. A way of saying The Maximum Integer is 0 + q/inf/.
-
sub min_gap{
my($min_gap, $element_min_gap) = (0 + q/inf/, 0 + q/inf/);
{
my $x = shift@_;
my $y = shift@_;
if($x && $y){
my $gap = $y - $x;
if($gap < $min_gap){
$min_gap = $gap;
$element_min_gap = $y;
}
}
unshift@_, $y;
redo if@_ > 1;
}
return $element_min_gap;
}
◇
-
Fragment referenced in 1.
Now all we need are a few lines of code for running some tests.
-
MAIN:{
say min_gap 2, 8, 10, 11, 15;
say min_gap 1, 5, 6, 7, 14;
say min_gap 8, 20, 25, 28;
}
◇
-
Fragment referenced in 1.
Sample Run
$ perl perl/ch-1.pl 11 6 28
Part 2: Min Diff
You are given an array of integers, @ints. Write a script to find the minimum difference between any two elements.
From Part 1 we know that if we sort the list we know we need to only check adjacent elements to find the minimum difference.
-
sub min_diff{
my $min_gap = 0 + q/inf/;
my@i = sort {$a <=> $b}@_;
{
my $x = shift@i;
my $y = shift@i;
if($x && $y){
my $gap = $y - $x;
$min_gap = $gap if $gap < $min_gap;
}
unshift@i, $y;
redo if@i > 1;
}
return $min_gap;
}
◇
-
Fragment referenced in 5.
Finally, here’s a few tests to confirm everything is working right.
Sample Run
$ perl ch-2.pl 1 2
References
posted at: 19:58 by: Adam Russell | path: /perl | permanent link to this entry