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. "ch-1.pl" 1≡ use GD; use JSON; use OCR::OcrSpace; ⟨write text to image 3 ⟩ ⟨ocr image 4 ⟩ ⟨main 5 ⟩ ◇ 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. ⟨replace all non-digit characters with a space 2 ⟩≡ $s =~ tr/a-z/ /; ◇ Fragment referenced in 4. Uses: $s 4. 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. ⟨write text to image 3 ⟩≡ 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; ret

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. "ch-1.pl" 1≡ use v5.40; ⟨replace all ?s 2 ⟩ ⟨main 4 ⟩ ◇ 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. ⟨replace all ?s 2 ⟩≡ 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/?/){ ⟨replace 3 ⟩ 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; } ◇ Fragment referenced in 1. Defines: $after 3, $before 3, $replace 3. 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. ⟨replace 3 ⟩≡ do{

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. "ch-1.pl" 1≡ use v5.40; ⟨find missing 2 ⟩ ⟨main 3 ⟩ ◇ 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. ⟨find missing 2 ⟩≡ 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 3 ⟩≡ 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. "ch-2.pl" 4≡ use v5.40; </spa

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. "ch-1.p" 1≡ ⟨missing integers 2 ⟩ ◇ This problem is straightforward to solve using member/2. ⟨missing integers 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. "ch-2.p" 3≡ ⟨compute MAD and find pairs 4 ⟩ ◇ 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 sa

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. "ch-1.pl" 1≡ use v5.40; ⟨compute the day of the year 2 ⟩ ⟨main 4 ⟩ ◇ The answer is arrived at via a fairly straightforward calculation. ⟨compute the day of the year 2 ⟩≡ sub day_of_year { my ($date) = @_; my $day_of_year = 0; my ($year, $month, $day) = split /-/, $date; ⟨determine if this is a leap year 3 ⟩ 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; } ◇ Fragment referenced in 1. Defines: $year 3. Uses: $february_days 3. 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. ⟨determine if this is a leap year 3 ⟩≡ my $is_leap_year = ($year % 400 == 0) || ($year % 4 == 0 && $year % 100 != 0); my $february_days = $is_leap_year ? 29 : 28; ◇ Fragment referenced in 2. Defines: $february_days 2, $is_leap_year Never used. Uses: $year 2. 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 4 ⟩≡ 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! "ch-2.pl" 5≡ use v5.40; ⟨decompress list 6 ⟩ ⟨main 7 ⟩ ◇ 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. ⟨decompress list 6 ⟩≡ 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<span class="ec-lmr

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. "ch-1.p" 1≡ ⟨day month year 4 ⟩ ⟨leap year 2 ⟩ ⟨february days 3 ⟩ ⟨day of the year 5 ⟩ ◇ We’ll put the determination of whether a year is a leap year or not into its own predicate. ⟨leap year 2 ⟩≡ 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 3 ⟩≡ 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 4 ⟩≡ 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 the year 5 ⟩≡ 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. "ch-2.p" 6≡ ⟨state of the decompression 7 ⟩ ⟨decompress 8 ⟩ ⟨decompress list 9 ⟩ ◇ 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. ⟨state of the decompression 7 ⟩≡ decompression(Decompression), [Decompression] --g

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. "ch-1.p" 1≡ ⟨state of the count 2 ⟩ ⟨count consecutive ones 3 ⟩ ⟨consecutive ones 4 ⟩ ◇ 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. ⟨state of the count 2 ⟩≡ 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 consecutive ones 3 ⟩≡ 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 4 ⟩≡ 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. "ch-2.p" 5≡ ⟨next smallest 6 ⟩ ⟨compute lowest prices 7 ⟩ ◇ Given a list and a price find the next smallest price in the list. ⟨next smallest 6 ⟩≡ 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 prices 7 ⟩≡ compute_lowest([], []). compute_lowest([H|

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. "ch-1.pl" 1≡ use v5.40; ⟨create 2d array 2 ⟩ ⟨main 3 ⟩ ◇ ⟨create 2d array 2 ⟩≡ 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 3 ⟩≡ 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. "ch-2.pl" 4≡ use v5.40; ⟨power set calculation 7 ⟩ ⟨calculate the total XOR 6 ⟩ ⟨main 5 ⟩ ◇ The main section is just some basic tests. ⟨main 5 ⟩≡ 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. ⟨calculate the total XOR 6 ⟩≡ 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. <!-- l. 244 -

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. "ch-1.p" 1≡ ⟨create two dimensional array 2 ⟩ ◇ We’ll use a straightforward recursive approach. ⟨create two dimensional array 2 ⟩≡ 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. "ch-2.p" 3≡ ⟨subtotal 6 ⟩ ⟨compute total xor 4 ⟩ ⟨combine xors 5 ⟩ ◇ ⟨compute total xor 4 ⟩≡ 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 xors 5 ⟩≡ combine([], 0). combine([H|T], Combined):- combine(T, Combined1), Combined = xor(H, Combined1). ◇ Fragment referenced in 3. ⟨subtotal 6 ⟩≡ subtotal(Combined, X):- X is Combined. ◇ 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 |<sp

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. "IncrementDecrement.yp" 1≡ ⟨declarations 2 ⟩ %% ⟨rules 5 ⟩ %% ⟨programs 6 ⟩ ◇ The declarations section will have some token definitions and a global variable declaration. ⟨declarations 2 ⟩≡ ⟨tokens 3 ⟩ ⟨variables 4 ⟩ ◇ Fragment referenced in 1. For our simple language we’re just going to define a few tokens: the increment and decrement operators, our single letter variables. ⟨tokens 3 ⟩≡ %token INCREMENT %token DECREMENT %token LETTER %expect 2 ◇ Fragment referenced in 2. We’re going to define a single global variable which will be used to track the state of each variable. ⟨variables 4 ⟩≡ %{ my $variable_state = {}; %} ◇ Fragment referenced in 2. Defines: $variable_state 5, 10. 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 ⟨rules 5 ⟩≡ 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]}--} ; ◇ Fragment referenced in 1. Uses: $variable_state 4. 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. ⟨programs 6 ⟩≡ ⟨lexer 9 ⟩ ⟨parse function 7 ⟩ ⟨error handler 8 ⟩ ⟨clear variables defined in the grammar definition file declarations 10 ⟩ ◇ Fragment referenced in 1. 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

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. "ch-1.p" 1≡ ⟨update input variables 4 ⟩ ⟨state of the variables 2 ⟩ ⟨process input 3 ⟩ ⟨show final state of the variables 5 ⟩ ⟨increment decrement 6 ⟩ ◇ 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. ⟨state of the variables 2 ⟩≡ 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 3 ⟩≡ 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. ⟨update input variables 4 ⟩≡ 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 final state of the variables 5 ⟩≡ 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 6 ⟩≡ increment_decrement(Input):- phrase(process(Input),

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. "ch-1.pl" 1≡ ⟨preamble 2 ⟩ ⟨process string as a list of characters 4 ⟩ ⟨main 3 ⟩ ◇ The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version. ⟨preamble 2 ⟩≡ use v5.40; ◇ Fragment referenced in 1, 5. the main section is just some basic tests. ⟨main 3 ⟩≡ 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. ⟨process string as a list of characters 4 ⟩≡ 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. "ch-2.pl" 5≡ ⟨preamble 2 ⟩ ⟨number larger 9 ⟩ ⟨rank the elements in a list 7 ⟩ ⟨main 6 ⟩ ◇ The main section is just some basic tests. ⟨main 6 ⟩≡ 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. ⟨rank the elements in a list 7 ⟩≡ sub rank_array{ my(@i) = @_; my %h; my @unique = (); ⟨determine unique values from the given array of integers 8 ⟩ @unique = keys %h; return map {number_larger $_, [@unique]} @i; } ◇ Fragment referenced in 5. We use a hash to determine the unique values in the given array ⟨determine unique values from the given array of integers 8 ⟩≡ do{$h{$_} = undef} for @i; ◇ Fragment referenced in 7. Here’s where we compute how many unique numbers are larger than any given one ⟨number larger 9 ⟩≡ 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 The Weekly Challenge 322 Generated Code

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. "ch-1.p" 1≡ ⟨state of the formatted string 2 ⟩ ⟨process string 3 ⟩ ⟨string format 4 ⟩ ◇ 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. ⟨state of the formatted string 2 ⟩≡ 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 3 ⟩≡ 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 4 ⟩≡ 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. "ch-2.p" 5≡ ⟨rank lookup  6 ⟩ ⟨rank list 7 ⟩ ◇ This is a predicate we’ll call via maplist. ⟨rank lookup  6 ⟩≡ rank(SortedList, X, Rank):- nth(Rank, SortedList, X). ◇ Fragment referenced in 5. We’ll define a predicate to do an initial sort and call rank/3. ⟨rank list 7 ⟩≡ 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 The Weekly Challenge 322 Generated Code

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. "ch-1.pl" 1≡ ⟨preamble 2 ⟩ ⟨distinct average calculation 4 ⟩ ⟨main 3 ⟩ ◇ The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version. ⟨preamble 2 ⟩≡ use v5.40; ◇ Fragment referenced in 1, 8. the main section is just some basic tests. ⟨main 3 ⟩≡ 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. ⟨distinct average calculation 4 ⟩≡ sub distinct_average{ my @numbers = ⟨sort the given numbers in ascending order 5 ⟩ my %averages; ⟨loop over the sorted numbers, compute and track the averages 6 ⟩ return 0 + keys %averages; } ◇ Fragment referenced in 1. Defines: %averages Never used, @numbers 6, @_ 5. ⟨sort the given numbers in ascending order 5 ⟩≡ sort {$a <=> $b} @_; ◇ Fragment referenced in 4. Uses: @_ 4. ⟨loop over the sorted numbers, compute and track the averages 6 ⟩≡ for my $i (0 .. (@numbers / 2)){ my($x, $y) = ($numbers[$i], $numbers[@numbers - 1 - $i]); $averages{⟨average computed to 7 decimal place 7 ⟩} = undef; } ◇ Fragment referenced in 4. Defines: $x 7, $y 7. Uses: @numbers 4. ⟨average computed to 7 decimal place 7 ⟩≡ sprintf(q/%0.7f/, (($x + $y)/2)) ◇ Fragment referenced in 6. Uses: $x 6, $y 6. 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. "ch-2.pl" 8≡ ⟨preamble 2 ⟩ ⟨process strings  10 ⟩ ⟨main 9 ⟩ ◇ The main section is just some basic tests. ⟨main 9 ⟩≡ 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. ⟨process strings  10 ⟩≡ 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 The Weekly Challenge 321 Generated Code

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. "ch-1.p" 1≡ ⟨first last 2 ⟩ ⟨distinct average 3 ⟩ ◇ We’ll define a predicate for getting the minimum/maximum pairs. These will be the first/last pairs from a sorted list. ⟨first last 2 ⟩≡ 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 3 ⟩≡ 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. "ch-2.p" 4≡ ⟨state of the character list 5 ⟩ ⟨process string 6 ⟩ ⟨backspace compare 7 ⟩ ◇ Let’s have some predicates for maintaining the state of a character list as the DCG processes the string. ⟨state of the character list 5 ⟩≡ 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 6 ⟩≡ 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 7 ⟩≡ 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 The Weekly Challenge 321 Generated Code

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. "ch-1.p" 1≡ ⟨identify negatives 2 ⟩ ⟨identify positives 3 ⟩ ⟨count negatives 4 ⟩ ⟨count positives 5 ⟩ ⟨maximum count 6 ⟩ ◇ 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 2 ⟩≡ identify_negatives(Number, 1):- Number < 0. identify_negatives(_, 0). ◇ Fragment referenced in 1. ⟨identify positives 3 ⟩≡ identify_positives(Number, 1):- Number > 0. identify_positives(_, 0). ◇ Fragment referenced in 1. ⟨count negatives 4 ⟩≡ count_negatives(Numbers, Count):- maplist(identify_negatives, Numbers, Negatives), sum_list(Negatives, Count). ◇ Fragment referenced in 1. ⟨count positives 5 ⟩≡ 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 6 ⟩≡ 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. "ch-2.p" 7≡ ⟨char_number 10 ⟩ ⟨element sum 8 ⟩ ⟨digit sum 9 ⟩ ⟨sum differences 11 ⟩ ◇ The element sum is a straightforward application of the builtin predicate sum_list/2. ⟨element sum 8 ⟩≡ 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 9 ⟩≡ 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. ⟨char_number 10 ⟩≡ char_number(C, N):- number_chars(N, [C]). ◇ Fragment referenced in 7. sum_difference/2 is the main predicate, which calls the others we’ve defined so far. ⟨sum differences 11 ⟩≡ 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 The Weekly Challenge 320 Generated Code

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. "ch-1.pl" 1≡ ⟨preamble 2 ⟩ ⟨filter and count the positive/negative numbers, compute maximum 4 ⟩ ⟨main 3 ⟩ ◇ The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version. ⟨preamble 2 ⟩≡ use v5.40; ◇ Fragment referenced in 1, 7. the main section is just some basic tests. ⟨main 3 ⟩≡ 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. ⟨filter and count the positive/negative numbers, compute maximum 4 ⟩≡ sub maximum_count{ my @numbers = @_; ⟨filter negatives 5 ⟩ ⟨filter positives 6 ⟩ return (sort {$b <=> $a} ($positives, $negatives))[0]; } ◇ Fragment referenced in 1. Defines: @numbers 5, 6. Uses: $negatives 5, $positives 6. We do the filtering with a grep. ⟨filter negatives 5 ⟩≡ my $negatives = 0 + grep {$_ < 0} @numbers; ◇ Fragment referenced in 4. Defines: $negatives 4. Uses: @numbers 4. ⟨filter positives 6 ⟩≡ my $positives = 0 + grep {$_ > 0} @numbers; ◇ Fragment referenced in 4. Defines: $positives 4. Uses: @numbers 4. 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. "ch-2.pl" 7≡ ⟨preamble 2 ⟩ ⟨compute the digit sum and element sum and then subtract 9 ⟩ ⟨main 8 ⟩ ◇ The main section is just some basic tests. ⟨main 8 ⟩≡ 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. ⟨compute the digit sum and element sum and then subtract 9 ⟩≡ sub sum_difference{ my @numbers = @_; ⟨digit sum 10 ⟩ ⟨element sum 11 ⟩ return abs($digit_sum - $element_sum); } ◇ Fragment referenced in 7. Defines: @numbers 10, 11. Uses: $digit_sum 10, $element_sum 11. We compute the digit sum by splitting each element as a string and then summing the list of digits. ⟨digit sum 10 ⟩≡ my @digits; do{ push @digits, split //, $_; } for @numbers; my $digit_sum = unpack(q/%32I*/, pack(q/I*/, @digits)); ◇ Fragment referenced in 9. Defines: $digit_sum 9. Uses: @numbers 9. The element sum is a straightforward summing of the elements. ⟨element sum 11 ⟩≡ my $element_sum = unpack(q/%32I*/, pack(q/I*/, @numbers)); ◇ Fragment referenced in 9. Defines: $element_sum 9. Uses: @numbers 9. Sample Run $ perl perl/ch-2.pl 18 0 27 References The Weekly Challenge 320 Generated Code

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. "ch-1.pl" 1≡ ⟨preamble 2 ⟩ ⟨count the words that begin or end with a vowel 4 ⟩ ⟨main 3 ⟩ ◇ The preamble is just whatever we need to include. Here we aren’t using anything special, just specifying the latest Perl version. ⟨preamble 2 ⟩≡ use v5.40; ◇ Fragment referenced in 1, 6. the main section is just some basic tests. ⟨main 3 ⟩≡ 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. ⟨count the words that begin or end with a vowel 4 ⟩≡ sub word_count{ return 0 + grep { ⟨start/end vowel check 5 ⟩ } @_; } ◇ Fragment referenced in 1. 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. ⟨start/end vowel check 5 ⟩≡ $_ =~ m/^[aeiou]/ || $_ =~ m/.*[aeiou]$/ ◇ Fragment referenced in 4. 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. "ch-2.pl" 6≡ ⟨preamble 2 ⟩ sub minimum_common{ my($u, $v) = @_; ⟨find common elements 7 ⟩ return $minimum; } ⟨main 8 ⟩ ◇ Defines: $u 7, $v 7. Uses: $minimum 7. 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. ⟨find common elements 7 ⟩≡ my %h = (); my %h_u = map {$_ => undef} @{$u}; my %h_v = map {$_ => undef} @{$v}; my $minimum = -1; do{ $h{$_}++; } for (keys %h_u, keys %h_v); my @common = grep {$h{$_} > 1} keys %h; if(0 < @common){ $minimum = (sort {$a <=> $b} @common)[0]; } ◇ Fragment referenced in 6. Defines: $minimum 6. Uses: $u 6, $v 6. ⟨main 8 ⟩≡ 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 The Weekly Challenge 319 Generated Code

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. "ch-1.p" 1≡ ⟨vowels 2 ⟩ ⟨start_end_vowel 3 ⟩ ⟨word count 4 ⟩ ◇ We’re going to be using character codes for this. For convenience let’s declare are vowels this way. ⟨vowels 2 ⟩≡ 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 3 ⟩≡ 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 4 ⟩≡ 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. "ch-2.p" 5≡ ⟨minimum common 7 ⟩ ◇ 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. ⟨subtract lists to determine common elemets 6 ⟩≡ subtract(List1, List2, Difference1), subtract(List2, List1, Difference2), append(Difference1, Difference2, Differences), subtract(List1, Differences, Common), ◇ Fragment referenced in 7. Defines: Common 7. minimum_common/3 is the main (and only) predicate we define ⟨minimum common 7 ⟩≡ minimum_common(List1, List2, MinimumCommon):- ⟨subtract lists to determine common elemets 6 ⟩ length(Common, L), L >= 1, min_list(Common, MinimumCommon). minimum_common(_, _, -1). ◇ Fragment referenced in 5. Uses: Common 6. 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 The Weekly Challenge 319 Generated Code

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. ⟨groupings 1 ⟩≡ 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... "ch-1.pl" 2≡ ⟨preamble 3 ⟩ ⟨groupings 1 ⟩ ⟨main 4 ⟩ ◇ ⟨preamble 3 ⟩≡ use v5.40; ◇ Fragment referenced in 2, 7. The rest of the code just runs some basic tests. ⟨main 4 ⟩≡ 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 ⟨scan both arrays 5 ⟩≡ my $indices_different = []; for my $i (0 .. @{$u} - 1){ push @{$indices_different}, $i unless $u->[$i] eq $v->[$i]; } ◇ Fragment referenced in 7. Defines: $indices_different 6. Uses: $u 7, $v 7. Now let’s check and see how many differences were found. ⟨review the differences found 6 ⟩≡ 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; ◇ Fragment referenced in 7. Uses: $indices_different 5, $s 7, $t 7, $u 7, $v 7. The rest of the code combines the previous steps and drives some tests. "ch-2.pl" 7≡ ⟨preamble 3 ⟩ sub reverse_equals{ my($u, $v) = @_; my($s, $t) = ([@{$u}], [@{$v}]); ⟨scan both arrays 5 ⟩ ⟨review the differences found 6 ⟩ } ⟨main 8 ⟩ ◇ Defines: $s 6, $t 6, $u 5, 6, $v 5, 6. ⟨main 8 ⟩≡ 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 The Weekly Challenge 318 Generated Code

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. ⟨utility predicate for finding groups 1 ⟩≡ 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 2 ⟩≡ 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. "ch-1.p" 3≡ ⟨utility predicate for finding groups 1 ⟩ ⟨groupings 2 ⟩ ◇ 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. ⟨test elements 4 ⟩≡ subtract(List1, List2, []), ◇ Fragment referenced in 8. Uses: List1 8, List2 8. ⟨find differences 5 ⟩≡ length(List1, Length), findall(I, ( between(1, Length, I), nth(I, List1, C1), nth(I, List2, C2), \+ C1 = C2 ), DifferenceIndices), ◇ Fragment referenced in 8. Defines: DifferenceIndices 6, 8. Uses: List1 8, List2 8. ⟨get sublists 6 ⟩≡ 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), ◇ Fragment referenced in 8. Defines: SubList1 7, SubList2 7. Uses: DifferenceIndices 5, List1 8, List2 8. ⟨test sublists and their reversals 7 ⟩≡ 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)) ◇ Fragment referenced in 8. Uses: List1 8, List2 8, SubList1 6, SubList2 6. All these pieces will be assembled into reverse_equals/2. ⟨reverse equals 8 ⟩≡ reverse_equals(List1, List2):- ⟨test elements 4 ⟩ ⟨find differences 5 ⟩ ⟨get sublists 6 ⟩ ⟨test sublists and their reversals 7 ⟩. reverse_equals(List1, List2):- ⟨test elements 4 ⟩ ⟨find differences 5 ⟩ length(DifferenceIndices, NumberDifferences), NumberDifferences = 0. ◇ Fragment referenced in 9. Defines: List1 4, 5, 6, 7, List2 4, 5, 6, 7. Uses: DifferenceIndices 5. Finally, let’s assemble our completed code into a single file. "ch-2.p" 9≡ ⟨reverse equals 8 ⟩ ◇ 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 The Weekly Challenge 318 Generated Code

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 1 ⟩≡ 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. "ch-1.p" 2≡ ⟨acronym 1 ⟩ ◇ 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 3 ⟩≡ 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. "ch-2.p" 4≡ ⟨friendly 3 ⟩ ◇ Sample Run $ gprolog --consult-file prolog/ch-2.p | ?- friendly("desc", "dsec"). yes | ?- friendly("cat", "dog"). no | ?- friendly("stripe", "sprite"). yes | ?- References The Weekly Challenge 317 Generated Code