Challenge 236 Task 1 and 2 solutions in Perl by Matthias Muth

6 files changed, 648 insertions, 93 deletions

diff --git a/challenge-236/matthias-muth/README.md b/challenge-236/matthias-muth/README.md
index d4c3c937ff..ccbb3acebb 100644
--- a/challenge-236/matthias-muth/README.md
+++ b/challenge-236/matthias-muth/README.md
@@ -1,129 +1,150 @@
-# Ones Removed and Zeros Duplicated
+# Bills in Loops, and Loops in Arrays
 
-**Challenge 235 solutions in Perl by Matthias Muth**
+**Challenge 236 solutions in Perl by Matthias Muth**
 
-## Task 1: Remove One
+## Task 1: Exact Change
 
-> You are given an array of integers.<br/>
-> Write a script to find out if removing ONLY one integer makes it strictly increasing order.<br/>
-> <br/>
+> You are asked to sell juice each costs \$5. You are given an array of bills. You can only sell ONE juice to each customer but make sure you return exact change back. You only have \$5, \$10 and \$20 notes. You do not have any change in hand at first.<br/>
+> Write a script to find out if it is possible to sell to each customers with correct change.<br/>
+> <br/> 
 > Example 1<br/>
-> Input: @ints = (0, 2, 9, 4, 6)<br/>
+> Input: @bills = (5, 5, 5, 10, 20)<br/>
 > Output: true<br/>
-> Removing ONLY 9 in the given array makes it strictly increasing order.<br/>
+> From the first 3 customers, we collect three \$5 bills in order.<br/>
+> From the fourth customer, we collect a \$10 bill and give back a \$5.<br/>
+> From the fifth customer, we give a \$10 bill and a \$5 bill.<br/>
+> Since all customers got correct change, we output true.<br/>
 > <br/>
 > Example 2<br/>
-> Input: @ints = (5, 1, 3, 2)<br/>
+> Input: @bills = (5, 5, 10, 10, 20)<br/>
 > Output: false<br/>
+> From the first two customers in order, we collect two \$5 bills.<br/>
+> For the next two customers in order, we collect a \$10 bill and give back a \$5 bill.<br/>
+> For the last customer, we can not give the change of \$15 back because we only have two \$10 bills.
+> Since not every customer received the correct change, the answer is false.<br/>
 > <br/>
 > Example 3<br/>
-> Input: @ints = (2, 2, 3)<br/>
+> Input: @bills = (5, 5, 5, 20)<br/>
 > Output: true<br/>
 
-For this task, I see two approaches:
-
-#### 1. Single Pass
-
-In this approach, we walk through the array only once.<br/>For each entry we check whether the following entry is greater.<br/>If not, we remove that violating following entry, and then we make sure with the rest of the list that this is the only violation.
-
-For example:
-  ```perl
-  1-2-3-0-4-5-6
-  ```
-We check `1 < 2` and `2 < 3`, which both are fine. Then we check `3 < 0`, which violates the rule.
-  We found a decrease, so we conclude that the `0` needs to be removed.
-  We check again for the new pair (`3 < 4`), and then the rest of the list (`4 < 5`, `5 < 6`) and find them all ok.<br/>So the `0` is the only entry that needs to be removed.
-
-And we are right in this case. But things are more complicated!
-
-Consider the next example:
-    ```perl
-  1-2-3-99-4-5-6
-    ```
-
-We check `1 < 2`, `2 < 3`, `3 < 99` and they are all ok, strictly increasing. Then we find a failure checking `99 < 4`, and we conclude that the `4` needs to be removed.
-
-But this is wrong!
-
-In this case, it's actually the *first* of the two numbers that we just compared that has to be removed to recreate a strictly increasing order, not the second.
-
-So we actually need to decide which of the two numbers we need to remove (we are sure that one of them has to go, if not, the violation will remain).
-
-Once we remove one of the two numbers, the other one has to be in correct order with both entries to its left and its right. In the examples, we choose between
-
-​    `2-3-4` and `2-0-4`
-
-and between
-
-​    `3-99-5` and `3-4-5`
-
-respectively.
+My solution is based on these ideas:
 
-And actually it may be that removing neither of the two leads to a strictly increasing sequence. We then can return 'false' immediately.
+* We serve the customers with the smallest bills first, in order to get good change for the next ones. 
+* We keep track of our cash separately for each value, to make it easier to pay back starting with larger bills, then lower ones.
+* Whenever a customer can't be paid back his or her change it's a 'sudden death', we can return 'false' immediately. If we make it through the list, we return 'true'.
 
-In all of this, we need to verify that all the neighbors we check really exist, which bloats up the code a little.
+And that's basically all.
 
-**I did not implement this.**<br/>
-It already took long enough to describe this algorithm, and the other solution I am going to propose is so nice and looks so 'perlish' to me that I really didn't consider the effort.
-
-### 2. Just Try Them All
-
-The second approach is <u>much</u>(!!!) easier!
-
-We use a separate function that checks whether a given list is strictly monotonic.
-
-We go through the array entry by entry, remove that entry from the array, and check with the function whether the resulting array is strictly monotonic. We return 'true' if we find the first entry where this is the case. 
-
-To make it 'short'; here's my implementation:
+For sorting the customers, and for checking our cash in the right order, I define a function to sort numerically (as the default for `sort` is string comparison, which makes `"5"` larger than `"10"`):
 
 ```perl
-use List::Util qw( any all );
-
-sub is_monotonic( @a ) {
-    return all { $a[$_] > $a[ $_ - 1 ] } 1..$#a;
+sub sort_num( @values ) {
+    return sort { $a <=> $b } @values;
 }
+```
 
-sub remove_one( @ints ) {
-    return
-        any {
-            my @try = @ints;
-            splice @try, $_, 1, ();
-            is_monotonic @try;
-        } 0..$#ints;
+Then this is my solution:
+
+```perl
+sub exact_change( @bills ) {
+
+    # Keep a count of the bills we have, separately for each value.
+    my %cash = ();
+
+    # Serve all the customers,
+    # making sure we accept the lowest bills first, for getting change.
+    for ( sort_num @bills ) {
+
+        # Accept  the customer's bill.
+        ++$cash{$_};
+
+        # We need to give this change:
+        my $change_to_return = $_ - 5;
+
+        # Starting with the highest value available,
+        # return bills that are lower than or equal to
+        # the change we need to return.
+        for ( reverse sort_num keys %cash ) {
+            while ( $_ <= $change_to_return && $cash{$_} ) {
+                --$cash{$_};
+                $change_to_return -= $_;
+            }
+        }
+
+        # No success if we couldn't return the correct change.
+        return 0
+            if $change_to_return > 0;
+    }
+    # Success.
+    return 1;
 }
 ```
 
-## Task 2: Duplicate Zeros
+## Task 2: Array Loops
 
-> You are given an array of integers.<br/>
-> Write a script to duplicate each occurrence of ZERO in the given array and shift the remaining to the right but make sure the size of array remain the same.<br/>
-> <br/>Example 1<br/>
-> Input: @ints = (1, 0, 2, 3, 0, 4, 5, 0)<br/>
-> Ouput: (1, 0, 0, 2, 3, 0, 0, 4)<br/>
+> You are given an array of unique integers.<br/>
+> Write a script to determine how many loops are in the given array.<br/>
+> To determine a loop: Start at an index and take the number at array[index] and then proceed to that index and continue this until you end up at the starting index.<br/>
+> <br/>
+> Example 1<br/>
+> Input: @ints = (4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10)<br/>
+> Output: 3<br/>
+> To determine the 1st loop, start at index 0, the number at that index is 4, proceed to index 4, the number at that index is 15, proceed to index 15 and so on until you're back at index 0.<br/>
+> Loops are as below:<br/>
+> [4 15 1 6 13 5 0]<br/>
+> [3 8 7 18 9 16 12 17 2]<br/>
+> [14 11 19 10]<br/>
 > <br/>
 > Example 2<br/>
-> Input: @ints = (1, 2, 3)<br/>
-> Ouput: (1, 2, 3)<br/>
+> Input: @ints = (0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3,18,15,19)<br/>
+> Output: 6<br/>
+> Loops are as below:<br/>
+> [0]<br/>
+> [1]<br/>
+> [13 9 14 17 18 15 5 8 2]<br/>
+> [7 11 4 6 10 16 3]<br/>
+> [12]<br/>
+> [19]<br/>
 > <br/>
 > Example 3<br/>
-> Input: @ints = (0, 3, 0, 4, 5)<br/>
-> Ouput: (0, 0, 3, 0, 0)<br/>
+> Input: @ints = (9,8,3,11,5,7,13,19,12,4,14,10,18,2,16,1,0,15,6,17)<br/>
+> Output: 1<br/>
+> Loop is as below:<br/>
+> [9 4 5 7 19 17 15 1 8 12 18 6 13 2 3 11 10 14 16 0]<br/>
 
-I use the `splice` function to insert the additional zeros after where `grep` finds any zeros in the array.
+To detect a loop, we follow the 'path' of numbers, using each number as the next index, until we find the index that we started with.
 
-One trick is to start from the end of the array, so that the indexes of where to put in the additional zeros do not change when we add entries 'behind'.
+We use a `@visited` array to mark each number on the path, to avoid running into another loop that we already detected.
 
-Another trick is to just replace the rest of the array after a zero by a copy of the zero that is already there and all the following rest of the array, except its last element (to keep the total number of elements the same).<br/>
-This makes it possible to use just one splice call for each zero to insert:
+For each index that we visit, we check whether the number at that index points does not point outside the array (using `exists`, which is shorter than checking against the array bounds).<br/>
+None of the examples has any of these, but it's always better to be on the safe side in case we use other test input.
+
+So we loop through the array, trying every number as a possible first number of a loop if it was not yet visited before, either as a part of another loop or as a part of a non-loop sequence that we already tried.
+
+In this simple version we only count the loops, we don't store them for display.<br/>So that should be all:
 
 ```perl
-sub duplicate_zeros( @ints ) {
-    splice @ints, $_ + 1, $#ints - $_, ( @ints[ $_ .. $#ints - 1 ] )
-        for reverse grep $ints[$_] == 0, 0 .. $#ints - 1;
-    return @ints;
+sub array_loops( @ints ) {
+    my $n_loops = 0;
+    my @visited = ();
+
+    for my $start_index ( 0..$#ints ) {
+        next if $visited[$start_index];
+
+        my $i = $ints[$start_index];
+        while ( exists( $ints[$i] )
+            && ! $visited[$ints[$i]]
+            && $i != $start_index )
+        {
+            $visited[$i] = 1;
+            $i = $ints[$i];
+        }
+
+        ++$n_loops
+            if $i == $start_index;
+    }
+    return $n_loops;
 }
 ```
 
-I am quite happy with these three lines of code!
-
 #### **Thank you for the challenge!**
diff --git a/challenge-236/matthias-muth/blog.txt b/challenge-236/matthias-muth/blog.txt
new file mode 100644
index 0000000000..30484565aa
--- /dev/null
+++ b/challenge-236/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-236/challenge-236/matthias-muth#readme
diff --git a/challenge-236/matthias-muth/perl/TestExtractor.pm b/challenge-236/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..7913a6836b
--- /dev/null
+++ b/challenge-236/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,243 @@
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       The Test Data Extraction Machine (tm).
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+package TestExtractor;
+use Exporter 'import';
+our @EXPORT = qw( run_tests $verbose %options vsay pp np carp croak );
+
+use Data::Dump qw( pp );
+use Data::Printer;
+use Getopt::Long;
+use Cwd qw( abs_path );
+use File::Basename;
+use List::Util qw( any );
+use Test2::V0;
+use Carp;
+no warnings 'experimental::signatures';
+
+our ( $verbose, %options );
+sub vsay { say @_ if $verbose };
+
+sub run_tests() {
+
+    $| = 1;
+
+    GetOptions(
+        "v|verbose!" => \$verbose,
+    ) or do { say "usage!"; exit 2 };
+
+    my $dir = dirname abs_path $0;
+    my ( $challenge, $task ) =
+        abs_path( $0 ) =~ m{challenge-(\d+) .* (\d+)[^[/\\]*$}x;
+    unless ( $challenge && $task ) {
+        say STDERR "ERROR: ",
+            "Cannot determine challenge number or task number. Exiting.";
+        exit 1;
+    }
+
+    my $local_tests;
+    ( undef, $local_tests ) = read_task( *::DATA )
+	if fileno *::DATA;
+
+    my ( $task_title, $task_description ) =
+        read_task( "$dir/challenge-${challenge}.txt", $task );
+	# vsay $task_title;
+
+    my @tests = (
+        $local_tests      ? extract_tests( $local_tests )      : (),
+	$task_description ? extract_tests( $task_description ) : (),
+    );
+    # vsay pp( @tests );
+
+    ( my $sub_name = lc $task_title ) =~ s/\W+/_/g;
+    my $sub = \&{"::$sub_name"};
+
+    do {
+        my @input_params =
+	    @{$_->{INPUT}} == 1
+	    ? ( ref $_->{INPUT}[0] eq 'ARRAY'
+		&& ! grep( ref $_, @{$_->{INPUT}[0]} ) )
+		? @{$_->{INPUT}[0]}
+		: $_->{INPUT}[0]
+	    : @{$_->{INPUT}};
+	my $expected = $_->{OUTPUT};
+	my $diag =
+	    "$sub_name( " . pp( @input_params ) . " ) "
+	    . ( ( @$expected == 1 && $expected->[0] =~ /^(?:(true)|false)/ )
+	        ? "is $expected->[0]"
+		: ( "== " . pp( @{$_->{OUTPUT}} ) ) );
+
+	my $name = "$_->{TEST}";
+	$name .= ": $diag"
+	    if $_->{TEST} =~ /^(Test|Example)(?:\s+\d+)?$/;
+	$diag = "test: $diag";
+
+	my @output = $sub->( @input_params );
+
+	if ( @$expected == 1 && $expected->[0] =~ /^(?:(true)|false)/ ) {
+	    ok $1 ? $output[0] : ! $output[0], $name, $diag // ();
+	}
+	else {
+	    is \@output, $expected, $name, $diag // ();
+	}
+
+        # vsay "";
+
+    } for @tests;
+
+    done_testing;
+}
+
+sub read_task( $fd_or_filename, $wanted_task = undef ) {
+
+    my $fd;
+    if ( ref \$fd_or_filename eq 'SCALAR' ) {
+        open $fd, "<", $fd_or_filename
+            or die "ERROR: cannot open '$fd_or_filename': $!\n";
+    }
+    else {
+        # non-SCALARs, like __DATA__ GLOB.
+        $fd = $fd_or_filename;
+    }
+
+    my ( $task, $task_title, $task_text ) = ( -1, undef );
+    while ( <$fd> ) {
+        /^Task (\d+):\s*(.*?)\s*$/ and do {
+            $task = $1;
+            $task_title = $2
+                if $wanted_task && $task == $wanted_task;
+            next;
+        };
+
+        next
+            if $wanted_task && $task != $wanted_task;
+
+	$task_text .= $_;
+    }
+
+    return $task_title, $task_text;
+}
+
+sub extract_tests( $task_text ) {
+    # vsay "extract_tests( ", pp( $task_text ), " )";
+
+    # These regular expressions are used for extracting input or output
+    # test data.
+    my $var_name      = qr/ [\@\$]\w+ /x;
+    my $literal       = qr/ ".*?" | '.*?' | [+-]?\d+ | undef /x;
+    my $bracketed     = qr/ \[ [^\[]*? \] /xs;
+    my $parenthesized = qr/ \( [^\[]*? \) /xs;
+    my $entry         = qr/ $literal | $bracketed | $parenthesized /x;
+    my $list          = qr/ $entry (?: \s*,\s* $entry )* \s*,? /xs;
+
+    # The combination of what we expect as input or output data.
+    # Capture unparenthesized lists for special handling.
+    my $data_re = qr/ (?<lit>      $literal )
+		    | (?<br_list>     \[ \s* (?:$list)? \s* \] )
+		    | (?<par_list>    \( \s* (?:$list)? \s* \) )
+		    | (?<no_paren> $list ) /x;
+
+    my @tests;
+    while ( $task_text =~
+	/^((?:Example|Test).*?)\s*:?\s*$ .*?
+	    ^Input: \s* ( .*? ) \s*
+	    ^Out?put: \s* ( .*? ) \s*? (?=(?: ^$ | ^\S | \Z ))
+	/xmsg )
+    {
+	my ( $test, $input, $output) = ( $1, $2, $3 );
+	# vsay pp $test, $input, $output;
+
+	push @tests, { TEST => $test };
+
+	for ( $input, $output ) {
+	    # To avoid misinterpretations of '@' or '$' when the data is
+	    # 'eval'ed, we turn all double quotes into single quotes.
+	    s/\"/'/g;
+
+	    # We convert 'barewords' into quoted strings.
+	    # We search for these patterns, but we just skip them without
+	    # changing them:
+	    #  * 'Input:', 'Output:' at the beginning of the string,
+	    #  * quoted strings,
+	    #  * variable names having a $ or @ sigil.
+	    # After we are sure it's none of those, we also check unquoted
+	    # 'barewords' (here: combinations of letters, digits or underscores,
+	    # starting with a letter) and enclose them in single quotes.
+	    my $bareword = qr/ \b (?!undef) [a-z_][a-z0-9_]* \b /ix;
+	    while ( / ^Input: | ^Output: | '.*?' | [\$\@]$bareword
+		    | ( $bareword ) /xg )
+	    {
+		if ( $1 ) {
+		    my $p = pos();
+		    substr $_, $p - length( $1 ), length( $1 ), "'$1'";
+		    pos = $p + 2;
+		}
+	    }
+
+	    # As all arrays will be stored as array references, so we just
+	    # convert parentheses (...) to angle brackets [...].
+	    # s/\(/\[/g;
+	    # s/\)/\]/g;
+
+	    # Add missing commas between literals.
+	    while ( s/($literal)\s+($literal)/$1, $2/ ) {}
+	}
+
+	while ( $input =~ / ($var_name) \s* = \s* ($data_re) /xg ) {
+	    push @{$tests[-1]{VARIABLE_NAMES}}, $1;
+	    push @{$tests[-1]{INPUT}},
+		eval( ( $+{no_paren} || $+{par_list} ) ? "[ $2 ]" : $2 );
+        };
+
+	while ( $output =~ /^\s* ($data_re) $/xg ) {
+	    local $_ = $1;
+	    # vsay "\$_: <$_>";
+	    # Special case:  (1,2),(3,4),(5,6)
+	    # should become: [1,2],[3,4],[5,6] ]
+	    if ( $+{no_paren} && /$parenthesized/ ) {
+		# vsay "found special case <$_>";
+		s/\(/\[/g;
+		s/\)/\]/g;
+	    }
+	    push @{$tests[-1]{OUTPUT}},
+		eval( $+{no_paren} ? "( $_ )" : $_ );
+        };
+    }
+
+    unless ( @tests ) {
+	# Try an alternative description format:
+	# <input...> => <output...>
+	my $n_examples = 0;
+	while ( $task_text =~ /^( .*? ) \s* => \s* ( .* )$/xmg ) {
+	    # vsay pp @{^CAPTURE};
+	    push @tests, {
+	        TEST => "Example " . ++$n_examples,
+		INPUT => [ split " ", $1 ],
+		OUTPUT => [ $2 ],
+		VARIABLE_NAMES => [ '@input' ],
+	    }
+	}
+    }
+
+    # Use array refs for all OUTPUT lists if at least one of tests does.
+    if ( any { ref $_->{OUTPUT}[0] } @tests ) {
+	$_->{OUTPUT} = [ $_->{OUTPUT} ]
+	    for grep { ! ref $_->{OUTPUT}[0] } @tests;
+    }
+
+    return @tests;
+}
+
+1;
diff --git a/challenge-236/matthias-muth/perl/ch-1.pl b/challenge-236/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..442d6a169a
--- /dev/null
+++ b/challenge-236/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,122 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 236 Task 1: Exact Change
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.20;
+use strict;
+use warnings;
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+use lib '.';
+use TestExtractor;
+
+sub sort_num( @values ) {
+    return sort { $a <=> $b } @values;
+}
+
+sub exact_change_1( @bills ) {
+    @bills = sort_num @bills;
+    my %cash = ();
+    for ( @bills ) {
+	vsay "we are given \$$_";
+	my $change_to_return = $_ - 5;
+
+	if ( $change_to_return == 0 ) {
+	    vsay "    no need to return any change";
+	    ++$cash{$_};
+	    next;
+	}
+
+	# Start returning change with the highest bills available.
+	for ( reverse sort_num keys %cash ) {
+	    while ( $cash{$_} && $_ <= $change_to_return ) {
+		vsay "    returning a \$$_ bill";
+		--$cash{$_};
+		$change_to_return -= $_;
+	    }
+	}
+
+	# Check whether we returned all the necessary change.
+	if ( $change_to_return > 0 ) {
+	    vsay "    we don't have the right change";
+	    return 0; 
+	}
+
+	# Accept  the customer's bill.
+	++$cash{$_};
+	vsay "    accepting the customer's \$$_ bill";
+	vsay "    cash now: ", join( " ",
+	    map { ( "\$$_" ) x $cash{$_} } sort_num keys %cash );
+    }
+    return 1;
+}
+
+sub exact_change_2( @bills ) {
+    @bills = sort_num @bills;
+    my %cash = ();
+    for ( @bills ) {
+
+	# Accept  the customer's bill.
+	++$cash{$_};
+
+	# We need to give this change:
+	my $change_to_return = $_ - 5;
+
+	# Starting with the highest bills available,
+	# return bills that are lower than or equal to
+	# the change we need to return.
+	for ( reverse sort_num keys %cash ) {
+	    while ( $cash{$_} && $_ <= $change_to_return ) {
+		--$cash{$_};
+		$change_to_return -= $_;
+	    }
+	}
+	#
+	# No success.
+	return 0
+	    if $change_to_return > 0;
+    }
+    return 1;
+}
+
+sub exact_change( @bills ) {
+
+    # Keep a count of the bills we have, separately for each value. 
+    my %cash = ();
+
+    # Serve all the customers,
+    # making sure we accept the lowest bills first, for getting change.
+    for ( sort_num @bills ) {
+
+	# Accept  the customer's bill.
+	++$cash{$_};
+
+	# We need to give this change:
+	my $change_to_return = $_ - 5;
+
+	# Starting with the highest value available,
+	# return bills that are lower than or equal to
+	# the change we need to return.
+	for ( reverse sort_num keys %cash ) {
+	    while ( $_ <= $change_to_return && $cash{$_} ) {
+		--$cash{$_};
+		$change_to_return -= $_;
+	    }
+	}
+
+	# No success if we couldn't return the correct change.
+	return 0
+	    if $change_to_return > 0;
+    }
+    # Success.
+    return 1;
+}
+
+run_tests;
diff --git a/challenge-236/matthias-muth/perl/ch-2.pl b/challenge-236/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..9ba6a50ef8
--- /dev/null
+++ b/challenge-236/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,90 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 236 Task 2: Array Loops
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.20;
+use strict;
+use warnings;
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+use lib '.';
+use TestExtractor;
+
+sub array_loops_1( @ints ) {
+    my @loops;
+    my @visited = ();
+
+    for my $start_index ( 0..$#ints ) {
+	next if $visited[$start_index];
+
+	my @loop_indexes = ( $start_index );
+
+	vsay "starting at index $start_index";
+	my $i = $ints[$start_index];
+	while ( exists( $ints[$i] )
+	    && ! $visited[$ints[$i]]
+	    && $i != $start_index )
+	{
+	    vsay "  moving to index $i";
+	    push @loop_indexes, $i;
+	    $visited[$i] = 1;
+	    $i = $ints[$i];
+	}
+
+	if ( $i == $start_index ) {
+	    vsay "  we found a loop: @loop_indexes";
+	    push @loops, [ @loop_indexes ];
+	}
+    }
+    return scalar @loops;
+}
+
+
+sub array_loops( @ints ) {
+    my $n_loops = 0;
+    my @visited = ();
+
+    for my $start_index ( 0..$#ints ) {
+	next if $visited[$start_index];
+
+	vsay "starting at index $start_index";
+	my $i = $ints[$start_index];
+	while ( exists( $ints[$i] )
+	    && ! $visited[$ints[$i]]
+	    && $i != $start_index )
+	{
+	    vsay "  moving to index $i";
+	    $visited[$i] = 1;
+	    $i = $ints[$i];
+	}
+
+	if ( $i == $start_index ) {
+	    vsay "  we found a loop";
+	    ++$n_loops;
+	}
+    }
+    return $n_loops;
+}
+
+run_tests;
+
+__DATA__
+Test 1: Simple sequence
+Input: @ints = ( 0, 1, 2, 3, 4, 5 )
+Output: 6
+
+Test 2: No loop
+Input: @ints = ( 1, 2, 3, 4, 5 )
+Output: 0
+
+Test 2: One real loop
+Input: @ints = ( 1, 2, 0, 4, 5 )
+Output: 1
+
diff --git a/challenge-236/matthias-muth/perl/challenge-236.txt b/challenge-236/matthias-muth/perl/challenge-236.txt
new file mode 100644
index 0000000000..d406faa61e
--- /dev/null
+++ b/challenge-236/matthias-muth/perl/challenge-236.txt
@@ -0,0 +1,78 @@
+The Weekly Challenge - 236
+Monday, Sep 25, 2023
+
+
+Task 1: Exact Change
+Submitted by: Mohammad S Anwar
+
+You are asked to sell juice each costs $5. You are given an array of bills. You can only sell ONE juice to each customer but make sure you return exact change back. You only have $5, $10 and $20 notes. You do not have any change in hand at first.
+Write a script to find out if it is possible to sell to each customers with correct change.
+Example 1
+
+Input: @bills = (5, 5, 5, 10, 20)
+Output: true
+
+From the first 3 customers, we collect three $5 bills in order.
+From the fourth customer, we collect a $10 bill and give back a $5.
+From the fifth customer, we give a $10 bill and a $5 bill.
+Since all customers got correct change, we output true.
+
+Example 2
+
+Input: @bills = (5, 5, 10, 10, 20)
+Output: false
+
+From the first two customers in order, we collect two $5 bills.
+For the next two customers in order, we collect a $10 bill and give back a $5 bill.
+For the last customer, we can not give the change of $15 back because we only have two $10 bills.
+Since not every customer received the correct change, the answer is false.
+
+Example 3
+
+Input: @bills = (5, 5, 5, 20)
+Output: true
+
+
+Task 2: Array Loops
+Submitted by: Mark Anderson
+
+You are given an array of unique integers.
+Write a script to determine how many loops are in the given array.
+
+To determine a loop: Start at an index and take the number at array[index] and then proceed to that index and continue this until you end up at the starting index.
+
+Example 1
+
+Input: @ints = (4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10)
+Output: 3
+
+To determine the 1st loop, start at index 0, the number at that index is 4, proceed to index 4, the number at that index is 15, proceed to index 15 and so on until you're back at index 0.
+
+Loops are as below:
+[4 15 1 6 13 5 0]
+[3 8 7 18 9 16 12 17 2]
+[14 11 19 10]
+
+Example 2
+
+Input: @ints = (0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3,18,15,19)
+Output: 6
+
+Loops are as below:
+[0]
+[1]
+[13 9 14 17 18 15 5 8 2]
+[7 11 4 6 10 16 3]
+[12]
+[19]
+
+Example 3
+
+Input: @ints = (9,8,3,11,5,7,13,19,12,4,14,10,18,2,16,1,0,15,6,17)
+Output: 1
+
+Loop is as below:
+[9 4 5 7 19 17 15 1 8 12 18 6 13 2 3 11 10 14 16 0]
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 1st October 2023.