adamcrussell

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amsmath}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PROLOG}{\lstset{language=Prolog, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}
  
\begin{document}

\section*{The Weekly Challenge 325 (Prolog Solutions)}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1:  Consecutive One}

{\it 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.}


@s

Our solution is short and will be contained in a single file that has 
the following structure.

@o ch-1.p -i
@{
    @<state...@>
    @<count...@>
    @<consecutive...@>
@}

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.

@d state of the count
@{
    consecutive_ones(Consecutive), [Consecutive] --> [Consecutive].
    consecutive_ones(C, Consecutive), [Consecutive] --> [C].
@}

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.

@d count consecutive ones
@{
    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([]) --> [].
@}

Finally, let’s wrap the calls to the DCG in a small predicate using 
phrase/3.

@d consecutive ones
@{
    consecutive_ones(L, MaximumConsecutive):-
        phrase(count_ones(L), [[0, 0]], [Output]), !,
        [_, MaximumConsecutive] = Output.
@}

@S

\subsubsection*{Sample Run}
\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\subsection*{Part 2: Final Price}

{\it 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).}

@s

The code required is fairly small, we'll just need a couple of 
predicates.

@o ch-2.p -i
@{
    @<next smallest@>
    @<compute...@>
@}

Given a list and a price find the next smallest price in the list.

@d next smallest
@{
    next_smallest([], _, 0).
    next_smallest([H|_], Price, H):-
        H =< Price, !.
    next_smallest([H|T], Price, LowestPrice):-
        H > Price,
        next_smallest(T, Price, LowestPrice).
@}

@d compute lowest prices
@{
    compute_lowest([], []).
    compute_lowest([H|T], [LowestPrice|LowestPrices1]):-
        compute_lowest(T, LowestPrices1),
        next_smallest(T, H, Discount),
        LowestPrice is H - Discount.
@}
@S

\subsubsection*{Sample Run}

\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\section*{References}

\href{https://theweeklychallenge.org/blog/perl-weekly-challenge-325/}
{The Weekly Challenge 325}
\\
\href{https://github.com/manwar/perlweeklychallenge-club/tree/master/challenge-325/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amssymb}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PERL}{\lstset{language=Perl, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}

@r!
  
\begin{document}

\section*{Consecutive Search for Discount Prices}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1: Consecutive One}

{\it 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.}

!s

The core of the solution is contained in a main loop. The resulting code 
can be contained in a single file.

!o ch-1.pl -i
!{
    use v5.40;
    !<recursively...!>
    !<find...!>
    !<main!>
!}

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.

!d find the longest consecutive sequence of ones
!{
    sub consecutive_one{
        my(@i) = @_;
        my($consecutive, $max_consecutive) = (0, 0);
        consecutive_one_r(\@i, \$consecutive, \$max_consecutive);
        return $max_consecutive;
    }
!| $consecutive $max_consecutive !}

Now, let's define our recursion. We'll terminate the recursion when 
we've exhausted the input array.

!d recursively count consecutive ones
!{
    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.

!d main
!{
  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);
  } 
!}

!S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-1.pl
3
0
2
\end{SHELL}

\subsection*{Part 2: Final Price}

{\it 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).}

!s

Hey, let's use recursion again for this too\char33

!o ch-2.pl -i
!{
    use v5.40;
    !<search...!>
    !<calculate lowest prices!>
    !<main!>
!}

The main section is just some basic tests.

!d main
!{
  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;
  }
!}

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.

!d search for lower price
!{
    sub search_lower{
        my($prices, $price, $lower) = @_;
        if(@{$prices} > 0){
            my $next_price = shift @{$prices};
            search_lower($prices, $price, $lower) unless $next_price <= $price;
            $$lower = $next_price if $next_price <= $price;
        }
    }
!}

With that subroutine defined we can use it to solve the main task at 
hand.

!d calculate lowest prices
!{
    sub calculate_lowest_prices{
        my @prices = @_;
        my @lowest = ();
        for my $i (0 .. @prices - 1){
            my $lower = 0;
            search_lower [@prices[$i + 1 .. @prices - 1]], $prices[$i], \$lower;
            push @lowest, $prices[$i] - $lower;
        }
        return @lowest;
    }
!| $lower !}

!S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-2.pl
4, 2, 4, 2, 3
1, 2, 3, 4, 5
6, 0, 1, 5
\end{SHELL}

\section*{References}

\href{https://www.theweeklychallenge.org/blog/perl-weekly-challenge-325/}
{The Weekly Challenge 325}
\\
\href{https://www.github.com/manwar/perlweeklychallenge-club/tree/master/challenge-325/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amsmath}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PROLOG}{\lstset{language=Prolog, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}
  
\begin{document}

\section*{The Weekly Challenge 324 (Prolog Solutions)}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1: 2D Array}

{\it 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.}

@s

Our solution is short and will be contained in a single file that has 
the following structure.

@o ch-1.p -i
@{
    @<create...@>
@}

We'll use a straightforward recursive approach.

@d create two dimensional array
@{
    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).
@}

@S

\subsubsection*{Sample Run}
\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\subsection*{Part 2: Total XOR}

{\it You are given an array of integers. Write a script to return the 
sum of total XOR for every subset of given array.}

@s

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.

@o ch-2.p -i
@{
    @<subtotal@>
    @<compute...@>
    @<combine xors@>
@}

@d compute total xor
@{
    total_xor(L, Total):-
        findall(S, (
          sublist(S, L), 
          \+ S = []
        ), SubLists),
        maplist(combine, SubLists, Combined),
        maplist(subtotal, Combined, SubTotals),
        sum_list(SubTotals, Total).
@}

@d combine xors
@{
    combine([], 0).
    combine([H|T], Combined):-
        combine(T, Combined1),
        Combined = xor(H, Combined1).
@}

@d subtotal
@{
    subtotal(Combined, X):-
        X is Combined.
@}

@S

\subsubsection*{Sample Run}

\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\section*{References}

\href{https://theweeklychallenge.org/blog/perl-weekly-challenge-324/}
{The Weekly Challenge 324}
\\
\href{https://github.com/manwar/perlweeklychallenge-club/tree/master/challenge-324/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amssymb}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PERL}{\lstset{language=Perl, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}

@r!
  
\begin{document}

\section*{Two Dimensional XOR Not?}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1\char58 \; 2D Array}

{\it 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.}

!s

The core of the solution is contained in a main loop. The resulting code 
can be contained in a single file.

!o ch-1.pl -i
!{
    use v5.40;
    !<create 2d array!>
    !<main!>
!}

!d create 2d array
!{
    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;
    }
!}

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.

!d main
!{
  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;  
  } 
!}

!S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-1.pl
([1, 2], [3, 4])
([1, 2, 3])
([1], [2], [3], [4])
\end{SHELL}

\subsection*{Part 2\char58 \; Total XOR}

{\it You are given an array of integers. Write a script to return the 
sum of total XOR for every subset of given array.}

!s

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.

!o ch-2.pl -i
!{
    use v5.40;
    !<power set...!>
    !<calculate...!>
    !<main!>
!}

The main section is just some basic tests.

!d main
!{
  MAIN:{
    say calculate_total_xor 1, 3;
    say calculate_total_xor 5, 1, 6;
    say calculate_total_xor 3, 4, 5, 6, 7, 8;
  }
!}

!d calculate the total XOR
!{
    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;
    }
!}

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.

!d power set calculation
!{
    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;
    }
!}

!S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-2.pl
6
28
480
\end{SHELL}

\section*{References}

\href{https://mathworld.wolfram.com/PowerSet.html}
{Power Set Defined}
\\
\href{https://adamcrussell.livejournal.com/30842.html}
{Power Set Calculcation (C++) from TWC 141}
\\
\href{https://www.theweeklychallenge.org/blog/perl-weekly-challenge-324/}
{The Weekly Challenge 324}
\\
\href{https://www.github.com/manwar/perlweeklychallenge-club/tree/master/challenge-324/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amsmath}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PROLOG}{\lstset{language=Prolog, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}
  
\begin{document}

\section*{The Weekly Challenge 323 (Prolog Solutions)}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1: Increment Decrement}

{\it 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.}

@s

Our solution will be contained in a single file that has the following 
structure.

@o ch-1.p -i
@{
    @<update...@>
    @<state...@>
    @<process...@>
    @<show...@>
    @<increment decrement@>
@}

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.

@d state of the variables
@{
    variables(VariableState), [VariableState] --> [VariableState].
    variables(V, VariableState), [VariableState] --> [V].
@}

Now we need to process the input, which we'll treat as lists of
character codes.

@d process input
@{
    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([]) --> [].
@}

We'll define some utility predicates for updating the state of the 
variables in our DCG input.

@d update input variables
@{
    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).
@}

One more small utility predicate. This one is for displaying the final
results. It's intended to be called from maplist/2.

@d show final state of the variables
@{
    show_variables(X-I):-
        atom_codes(A, [X]),
        write(A),
        write(': '),
        write(I), nl.
@}

Finally, let's wrap the calls to the DCG in a small predicate using 
phrase/3. 

@d increment decrement
@{
    increment_decrement(Input):-
        phrase(process(Input), [[]], [Output]), !,
        maplist(show_variables, Output).
@}

@S

\subsubsection*{Sample Run}
\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\subsection*{Part 2: Tax Amount}

{\it You are given an income amount and tax brackets. Write a script to 
calculate the total tax amount.}

@s

While a DCG approach is also certainly possible for this second part 
we'll go with a more plain recursive solution.

@o ch-2.p -i
@{
    @<compute...@>
@}

The code is simple enough that it is pretty explainable in one single
code section. 

@d compute taxes
@{
    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)).
@}

@S

\subsubsection*{Sample Run}

\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\section*{References}

\href{https://theweeklychallenge.org/blog/perl-weekly-challenge-323/}
{The Weekly Challenge 323}
\\
\href{https://github.com/manwar/perlweeklychallenge-club/tree/master/challenge-323/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amssymb}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PERL}{\lstset{language=Perl, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}

@r!
  
\begin{document}

\section*{Incremental Taxation}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1\char58 \; Increment Decrement}

{\it 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.}

!s

Let's entertain ourselves with an over engineered solution\char33~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.

!o IncrementDecrement.yp -i
!{
    !<declarations!>
    
    %%
    
    !<rules!>
    
    %%
    
    !<programs!>
!}

The declarations section will have some token definitions and a global
variable declaration.

!d declarations
!{
  !<tokens!>
  !<variables!>
!}

For our simple language we're just going to define a few tokens: 
the increment and decrement operators, our single letter variables.

!d tokens
!{
  %token INCREMENT 
  %token DECREMENT 
  %token LETTER
  %expect 2
!}

We're going to define a single global variable which will be used to 
track the state of each variable.

!d variables
!{
  %{
      my $variable_state = {};  
  %}
!| $variable_state !}

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

!d rules
!{
  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 \textit{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.

!d programs
!{
  !<lexer!>
  !<parse function!>
  !<error handler!>
  !<clear...!>
!}

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.

!d parse function
!{
  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;  
  }
!}

This is really just about the most minimal error handling function there 
can be\char33~All this does is print \lq\lq syntax error\rq\rq when the 
parser encounters a problem.

!d error handler
!{
  sub error{
    exists $_[0]->YYData->{ERRMSG}
    and do{
        print $_[0]->YYData->{ERRMSG};
            return;
    };
    print "syntax error\n"; 
  }
!}

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.

!d lexer
!{
  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);
    }  
  }
!}

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.

!d clear variables defined in the grammar definition file declarations
!{
    sub clear{
        $variable_state = {};  
    }
!} 

Let's define a small file to drive some tests.

!o ch-1.pl -i
!{
    !<preamble!>
    !<print final state of the variables!>
    !<main!>
!}

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.

!d preamble
!{
    use v5.40;
    use IncrementDecrement;
    !<constant...!>
!}

!d constant declarations
!{
  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
!}

For printing the results in a nice way we'll define a small subroutine
to display the return value from the parser.

!d print final state of the variables
!{
    sub print_variables{
        my($results) = @_;
        for my $k (keys %{$results}){
            print $k;
            say qq/:\t$results->{$k}/;
        }
    }
!}

!d main
!{
  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);
  } 
!}

!S

\subsubsection*{Sample Run}
\begin{SHELL}
$ 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
\end{SHELL}

\subsection*{Part 2\char58 \; Tax Amount}

{\it You are given an income amount and tax brackets. Write a script to 
calculate the total tax amount.}

!s

After over doing the complexity for the first part, we'll make this one 
quite a bit shorter.

!o ch-2.pl -i
!{
    use v5.40;
    !<calculate...!>
    !<main!>
!}

The main section is just some basic tests.

!d main
!{
  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]];
  }
!}

!d calculate the total tax due
!{
    sub calculate_tax{
        my($income, $tax_brackets) = @_;
        !<sort...!>
        my $tax = 0;
        my $taxed = 0;
        my $taxable = 0;
        !<iterate...!>
        return $tax;
    }
!| $income $tax_brackets !}

!d sort tax brackets by income
!{
    $tax_brackets = [sort {$a->[0] <=> $b->[0]} @{$tax_brackets}];
!}

!d iterate over the tax brackets and compute the tax
!{
    {
        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;
    }
!| $tax !}

!S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-2.pl
2.65
0.25
0
\end{SHELL}

\section*{References}

\href{https\colon//www.theweeklychallenge.org/blog/perl-weekly-challenge-323/}
{The Weekly Challenge 323}
\\
\href{https\colon//www.github.com/manwar/perlweeklychallenge-club/tree/master/challenge-323/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amsmath}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PROLOG}{\lstset{language=Prolog, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}
  
\begin{document}

\section*{The Weekly Challenge 322 (Prolog Solutions)}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1:String Format}

{\it 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.}

@s

Our solution will be contained in a single file that has the following 
structure.

@o ch-1.p -i
@{
    @<state...@>
    @<process...@>
    @<string format@>
@}

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.

@d state of the formatted string
@{
    format_(Format), [Format] --> [Format].
    format_(F, Format), [Format] --> [F].
@}

Now we need to process the strings, which we'll treat as lists of
character codes.

@d process string
@{
    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([], _, _) --> [].
@}

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.

@d string format
@{
    string_format(String, I, FormattedString):-
        reverse(String, R),
        phrase(process(R, I, 0), [[]], [F]), !,
        atom_chars(FormattedString, F).
@}

@S

\subsubsection*{Sample Run}
\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\subsection*{Part 2: Rank Array}

{\it 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.}

@s

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. 

@o ch-2.p -i
@{
    @<rank lookup...@>
    @<rank list@>
@}

This is a predicate we'll call via maplist. 

@d rank lookup
@{
    rank(SortedList, X, Rank):-
        nth(Rank, SortedList, X).
@}

We'll define a predicate to do an initial sort and call rank/3.

@d rank list
@{
    rank_list(L, Ranks):-
        sort(L, Sorted),
        maplist(rank(Sorted), L, Ranks).
@}

@S

\subsubsection*{Sample Run}

\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\section*{References}

\href{https://theweeklychallenge.org/blog/perl-weekly-challenge-322/}
{The Weekly Challenge 322}
\\
\href{https://github.com/manwar/perlweeklychallenge-club/tree/master/challenge-322/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amssymb}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PERL}{\lstset{language=Perl, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}

@r:
  
\begin{document}

\section*{Ordered Format Array}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1\char58 \; String Format}

{\it 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.}

:s

Our solution will be pretty short, contained in just a single file that
has the following structure.

:o ch-1.pl -i
:{
    :<+preamble:>
    :<process...:>
    :<main:>
:}

The preamble is just whatever we need to include. Here we aren't using
anything special, just specifying the latest Perl version.

:d+ preamble
:{
  use v5.40; 
:}

the main section is just some basic tests.

:d main
:{
  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;
  }
:}

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 \lq\lq stack processing\rq\rq~is 
straightforward enough to not require a lot of extra explanation.

:d process string as a list of characters
:{
    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);
    }
:}

:S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-1.pl
ABC-DEF
A-BC-DE
A-BCDE
\end{SHELL}

\subsection*{Part 2\char58 \; Rank Array}

{\it You are given an array of integers. Write a script to return an 
array of the ranks of each element\char58 the lowest value has rank 1, 
next lowest rank 2, etc. If two elements are the same then they share 
the same rank.}

:s

Our solution will have the following structure.

:o ch-2.pl -i
:{
    :<+preamble:>
    :<number...:>
    :<rank...:>
    :<main:>
:}

The main section is just some basic tests.

:d main
:{
  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/)/;
  }
:}

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($n^2$) method.

:d rank the elements in a list
:{
    sub rank_array{
        my(@i) = @_;
        my %h;
        my @unique = ();
        :<determine unique...:>
        @unique = keys %h;
        return map {number_larger $_, [@unique]} @i;
    }
:}

We use a hash to determine the unique values in the given array

:d determine unique values from the given array of integers
:{
    do{$h{$_} = undef} for @i;
:}

Here's where we compute how many unique numbers are larger than any 
given one

:d number larger
:{
    sub number_larger{
        my($x, $unique) = @_;
        return @{$unique} - grep {$_ > $x} @{$unique};
    }
:}

:S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-2.pl
(4, 1, 3, 2)
(1, 1, 1)
(4, 1, 1, 3, 2)
\end{SHELL}

\section*{References}

\href{https\colon//www.theweeklychallenge.org/blog/perl-weekly-challenge-322/}
{The Weekly Challenge 322}
\\
\href{https\colon//www.github.com/manwar/perlweeklychallenge-club/tree/master/challenge-322/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amsmath}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PROLOG}{\lstset{language=Prolog, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}
  
\begin{document}

\section*{The Weekly Challenge 321 (Prolog Solutions)}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1: Distinct Average}

{\it 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.}

@s

Our solution will be pretty short, contained in just a single file that
has the following structure.

@o ch-1.p -i
@{
    @<first last@>
    @<distinct average@>
@}

We'll define a predicate for getting the minimum/maximum pairs. These
will be the first/last pairs from a sorted list.

@d first last
@{
    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).
@}

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.

@d distinct average
@{
    distinct_average(Numbers, DistinctAverage):-
        sort(Numbers, NumbersSorted),
        first_last(NumbersSorted, MinimumMaximumPairs),
        maplist(sum_list, MinimumMaximumPairs, MinimumMaximumSums),
        sort(MinimumMaximumSums, MinimumMaximumSumsSorted),
        length(MinimumMaximumSumsSorted, DistinctAverage).
@}

@S

\subsubsection*{Sample Run}
\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\subsection*{Part 2: Backspace Compare}

{\it 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.}

@s

We'll use a DCG approach to process the strings and maintain an list of
characters.

@o ch-2.p -i
@{
    @<state...@>
    @<process...@>
    @<backspace compare@>
@}

Let's have some predicates for maintaining the state of a character 
list as the DCG processes the string.

@d state of the character list
@{
    characters(Characters), [Characters] --> [Characters].
    characters(C, Characters), [Characters] --> [C].
@}

Now we need to process the strings, which we'll treat as lists of
character codes.

@d process string
@{
    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([]) --> [].
@}

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.

@d backspace compare
@{
    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.
@}

@S

\subsubsection*{Sample Run}

\begin{SHELL}
$ 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
| ?-
\end{SHELL}

\section*{References}

\href{https://theweeklychallenge.org/blog/perl-weekly-challenge-321/}
{The Weekly Challenge 321}
\\
\href{https://github.com/manwar/perlweeklychallenge-club/tree/master/challenge-321/adam-russell}
{Generated Code}

\end{document}

\documentclass{article}

\usepackage{color}
\definecolor{linkcolor}{rgb}{0, 0, 0.7}

\usepackage{amssymb}
\usepackage[backref, raiselinks, pdfhighlight=/O, pagebackref, 
hyperfigures, breaklinks, colorlinks, pdfpagemode=UseNone, 
pdfstartview=FitBH, linkcolor={linkcolor}, anchorcolor={linkcolor},
citecolor={linkcolor}, filecolor={linkcolor}, menucolor={linkcolor}, 
urlcolor={linkcolor}]{hyperref}
\usepackage{datetime}
\usepackage{listings}
\lstset{extendedchars=true, keepspaces=true, language=perl}
\lstnewenvironment{PERL}{\lstset{language=Perl, frame=lines}}{}
\lstnewenvironment{SHELL}{\lstset{language=bash, frame=lines}}{}

@r:
  
\begin{document}

\section*{Back to a Unique Evaluation}

{\it The examples used here are from the weekly challenge problem 
statement and demonstrate the working solution.}

\subsection*{Part 1\char58 \; Distinct Average}

{\it 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.}

:s

Our solution will be pretty short, contained in just a single file that
has the following structure.

:o ch-1.pl -i
:{
    :<+preamble:>
    :<distinct...:>
    :<main:>
:}

The preamble is just whatever we need to include. Here we aren't using
anything special, just specifying the latest Perl version.

:d+ preamble
:{
  use v5.40; 
:}

the main section is just some basic tests.

:d main
:{
  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;
  }
:}

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.

:d distinct average calculation
:{
    sub distinct_average{
        my @numbers = :<sort...:>
        my %averages;
        :<loop...:>
        return 0 + keys %averages;
    }
:| @_ @numbers %averages :}

:d sort the given numbers in ascending order
:{
    sort {$a <=> $b} @_;
:}

:d loop over the sorted numbers, compute and track the averages
:{
    for my $i (0 .. (@numbers / 2)){
        my($x, $y) = ($numbers[$i], $numbers[@numbers - 1 - $i]);
        $averages{:<average...:>} = undef;
    }
:| $x $y :}

:d average computed to 7 decimal place
:{
    sprintf(q/%0.7f/, (($x + $y)/2))
:}

:S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-1.pl
1
2
2
\end{SHELL}

\subsection*{Part 2\char58 \; Backspace Compare}

{\it 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.}

:s

Our solution will have the following structure.

:o ch-2.pl -i
:{
    :<+preamble:>
    :<process strings...:>
    :<main:>
:}

The main section is just some basic tests.

:d main
:{
  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/;
  }
:}

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.

:d process strings
:{
    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/;
    }
:}

:S

\subsubsection*{Sample Run}
\begin{SHELL}
$ perl perl/ch-2.pl
true
true
false
\end{SHELL}

\section*{References}

\href{https\colon//www.theweeklychallenge.org/blog/perl-weekly-challenge-321/}
{The Weekly Challenge 321}
\\
\href{https\colon//www.github.com/manwar/perlweeklychallenge-club/tree/master/challenge-321/adam-russell}
{Generated Code}

\end{document}