This week both tasks are a nice fit for the capabilities of pl augmented by List::Util, which is preloaded.

Task #1: Lexicographic Order The Perl Weekly Challenge 229 wants us to count dyslexic words, whose letters are sorted neither forwards nor backwards.

In the -B BEGIN handler define a comparison function. It zips the global all-characters list @a with its arguments. It returns true if all have only one unique value, i.e. are pairwise equal. -o loops over the words on the command line, splits them characterwise into @a and sorts them into @s. If these lists are equal, short circuit. Else if the character list is equal to the reverse of the sorted list, short circuit. Else increment the magic count variable $RESULT and output it automatically at process end.

pl -oB 'sub c { all { 1 == uniq @$_ } zip \@a, \@_ }' '
    @s = sort @a = split //; c @s or c reverse @s or ++$RESULT' abc bce cae
pl -oB 'sub c { all { 1 == uniq @$_ } zip \@a, \@_ }' '
    @s = sort @a = split //; c @s or c reverse @s or ++$RESULT' yxz cba mon

pl -oB 'sub c { all { 1 == uniq @$_ } zip \@a, \@_ }' '
    @s = sort @a = split //; c @s or c reverse @s or ++$R' abc bce cae
pl -oB 'sub c { all { 1 == uniq @$_ } zip \@a, \@_ }' '
    @s = sort @a = split //; c @s or c reverse @s or ++$R' yxz cba mon

1
2

Task #2: Two out of Three It wants us to count numbers occurring in at least two out of three lists.

We give the lists as strings on the command line. -o loops over them and eval turns them into Perl lists. Then we get uniq values from them (could have used uniqint, but this is shorter and more versatile.) The magical sort-numerically-at-end hash %NUMBER counts them. To only get those two or more, in the -E END handler Number culls all values beneath a threshold (default: 2.) The actual output shows the count and the key.

pl -oE Number '++$NUMBER{$_} for uniq eval'  '1, 1, 2, 4'  '2, 4'  4

pl -oE N '++$N{$_} for uniq eval'  '1, 1, 2, 4'  '2, 4'  4

       2: 2
       3: 4

pl -oE Number '++$NUMBER{$_} for uniq eval'  '4, 1'  '2, 4'  '1, 2'

pl -oE N '++$N{$_} for uniq eval'  '4, 1'  '2, 4'  '1, 2'

       2: 1
       2: 2
       2: 4

Task #1: Special Integers The Perl Weekly Challenge 195 wants us to count Special Integers within a given range. It defines Special Integers as those with no repeating digits.

This sets @ARGV with -A and loops over it with -o. Use a regexp to find duplicate digits. If none, increment magic print-at-end variable $RESULT:

pl -oA '1..15' '/(.).*\1/ or ++$RESULT'
pl -oA '1..35' '/(.).*\1/ or ++$RESULT'

pl -oA '1..15' '/(.).*\1/ or ++$R'
pl -oA '1..35' '/(.).*\1/ or ++$R'

14
32

Task #2: Most Frequent Even It wants us to count the even numbers and display the most frequent. If it's a tie, as in the 3^rd example, we shall display the smallest most frequent.

Loop over the command line args with -o and count if even. In the -E END handler find the maximal count, and then, of those that share it, display the minimum. Or, if none, -1. In the next two examples, compact it a bit, by remembering each max, as we count it:

pl -oE '$c = max values %c;
    say $c ? min grep { $c{$_} == $c } keys %c : -1' '
    $_ % 2 or ++$c{$_}' 1 1 2 6 2
pl -oE 'say min( grep { $c{$_} == $c } keys %c ) // -1' '
    $_ % 2 or $c = max $c, ++$c{$_}' 1 3 5 7
pl -oE 'say min( grep { $c{$_} == $c } keys %c ) // -1' '
    $_ % 2 or $c = max $c, ++$c{$_}' 6 4 4 6 1

2
-1
4

Golf: Sum Every 2^nd Digit The task is to print a cross total of only every other digit in given numbers.

When I started writing, this was the shortest reply. But already before submitting, it had been declassed. It simply loops over the command line args with -o. It gets every other character, in this case digit, with a globally matching regexp. It profits from the fact that List::Util is imported, and uses echo to display its result:

pl -o 'echo sum/.(.)/g' 10 101011 548915381 999999 2147483647 999999999

pl -o 'e sum/.(.)/g' 10 101011 548915381 999999 2147483647 999999999

0
1
26
27
29
36

Task #1: Twice Largest The Perl Weekly Challenge 191 wants us to find out whether the largest item in the list is at least twice as large as each of the other items.

Initialise $a to negative infinity and @ARGV with -A. Loop over it with -o. In the main part shift $a to $b each time we find a bigger one. So $b is the 2^nd biggest. (Note for the odd case of a single-item list, should init $b to infinity.) In the END handler -E check if the two numbers fulfill the criterion.

pl -oA '$a = -INF; 1..4' -E 'echo $a >= $b * 2 ? 1 : -1' '$b = $a, $a = $_ if $_ > $a'
pl -oA '$a = -INF; (1,2,0,5)' -E 'echo $a >= $b * 2 ? 1 : -1' '$b = $a, $a = $_ if $_ > $a'

pl -oA '$a = -INF; 1..4' -E 'e $a >= $b * 2 ? 1 : -1' '$b = $a, $a = $_ if $_ > $a'
pl -oA '$a = -INF; (1,2,0,5)' -E 'e $a >= $b * 2 ? 1 : -1' '$b = $a, $a = $_ if $_ > $a'

-1
1

Instead we can init $a in a BEGIN handler with -B and take @ARGV from the command line.

pl -oB '$a = -INF' -E 'echo $a >= $b * 2 ? 1 : -1' '$b = $a, $a = $_ if $_ > $a' 2 6 3 1
pl -oB '$a = -INF' -E 'echo $a >= $b * 2 ? 1 : -1' '$b = $a, $a = $_ if $_ > $a' 4 5 2 3

pl -oB '$a = -INF' -E 'e $a >= $b * 2 ? 1 : -1' '$b = $a, $a = $_ if $_ > $a' 2 6 3 1
pl -oB '$a = -INF' -E 'e $a >= $b * 2 ? 1 : -1' '$b = $a, $a = $_ if $_ > $a' 4 5 2 3

1
-1

Task #2: Cute List It wants us to check all permutations of a list 1..n and count how many are cute. They define cute lists as each 1-based index being cleanly divisible by its value or the other way round.

Algorithm::Permute::permute provides benchmarks showing it to be the fastest kid on the block. For the list use @ARGV, as it can be easily initialised with -A. Since bigger numbers can't cleanly divide smaller numbers, only try max % min. As soon as any one doesn't divide, we're done with this permutation. If it does, and it's the last index, increment magic print-at-end variable $RESULT.

pl -MAlgorithm::Permute=permute -A '1..5' 'permute {
    max(@l = ($_, $ARGV[$_ - 1])) % min(@l) ? last : ($_ == @ARGV && ++$RESULT) for 1..@ARGV
} @ARGV'

pl -MAlgorithm::Permute=permute -A '1..5' 'permute {
    max(@l = ($_, $A[$_ - 1])) % min(@l) ? last : ($_ == @A && ++$R) for 1..@A
} @A'

10

Task #1: Max Index The Perl Weekly Challenge 182 wants us to find the index of the first biggest number in a list.

Initialise running variable $x to negative infinity and @ARGV with -A. Loop over it with -o. Each time we find one, set magic print-at-end variable $RESULT to awk-style $ARGIND (or $I).

pl -oA '$x = -INF; (5, 2, 9, 1, 7, 6)' '$x = $_, $RESULT = $ARGIND if $x < $_'

pl -oA '$x = -INF; (5, 2, 9, 1, 7, 6)' '$x = $_, $R = $I if $x < $_'

2

Instead we can init $a in a BEGIN handler with -B and take @ARGV from the command line.

pl -oB '$x = -INF' '$x = $_, $RESULT = $ARGIND if $x < $_' 4 2 3 1 5 0

pl -oB '$x = -INF' '$x = $_, $R = $I if $x < $_' 4 2 3 1 5 0

4

Task #2: Common Path It wants us to determine the deepest path to the directory that contains all of a given a list of absolute Linux file paths,

Append current line with last remembered, and extract the common directories. In the END handler -E trim final slash, if it's not the root directory. If no common prefix was found, exit without output.

pl -nlE '$RESULT =~ s!.\K/$!!' '($RESULT) = "$_\n$RESULT" =~ /\A(.*\/).*(\n\1|\Z)/; $R // exit' <<EOF
/a/b/c/1/x.pl
/a/b/c/d/e/2/x.pl
/a/b/c/d/3/x.pl
/a/b/c/4/x.pl
/a/b/c/d/5/x.pl
EOF

pl -nlE '$R =~ s!.\K/$!!' '($R) = "$_\n$R" =~ /\A(.*\/).*(\n\1|\Z)/; $R // exit' <<EOF
/a/b/c/1/x.pl
/a/b/c/d/e/2/x.pl
/a/b/c/d/3/x.pl
/a/b/c/4/x.pl
/a/b/c/d/5/x.pl
EOF

/a/b/c

Same, looping over @ARGV with -o instead.

pl -oE '$RESULT =~ s!.\K/$!!' '($RESULT) = "$_\n$RESULT" =~ /\A(.*\/).*(\n\1|\Z)/; $R // exit' \
    /a/b/c/1/x.pl /a/b/c/d/e/2/x.pl /a/b/c/d/3/x.pl /a/b/c/4/x.pl /a/b/c/d/5/x.pl

pl -oE '$R =~ s!.\K/$!!' '($R) = "$_\n$R" =~ /\A(.*\/).*(\n\1|\Z)/; $R // exit' \
    /a/b/c/1/x.pl /a/b/c/d/e/2/x.pl /a/b/c/d/3/x.pl /a/b/c/4/x.pl /a/b/c/d/5/x.pl

/a/b/c

Task #1: Fortunate Numbers The Perl Weekly Challenge 155 wants us to produce first 8 Fortunate Numbers (unique and sorted). These, named after Reo Fortune, are the smallest integers m > 1 such that, for a given positive integer n, pn# + m is a prime number, where the primorial pn# is the product of the first n prime numbers.

Initialise @ARGV with -A. Loop over it with -O giving the elements in $ARGV. In helper list @b store the modulus. If it fulfills the condition move it to target list @b. Instead of comparing the lists, just compare lengths and the first item numerically, then the rest expensively by string concatenation.

pl -Mbignum -OA2..30 '@a = 0; @b = $a = $b = 1;
    while( @a != @b || $a[0] != $b[0] || "@a" ne "@b" ) {
        push @a, shift @b if @a < @b || $a[0] != $b[0];
        push @b, $b % $ARGV;
        ($a, $b) = ($b, $a + $b)
    }
    echo "$ARGV: @a"'

pl -Mbignum -OA2..30 '@a = 0; @b = $a = $b = 1;
    while( @a != @b || $a[0] != $b[0] || "@a" ne "@b" ) {
        push @a, shift @b if @a < @b || $a[0] != $b[0];
        push @b, $b % $A;
        ($a, $b) = ($b, $a + $b)
    }
    e "$A: @a"'

2: 0 1 1
3: 0 1 1 2 0 2 2 1
4: 0 1 1 2 3 1
5: 0 1 1 2 3 0 3 3 1 4 0 4 4 3 2 0 2 2 4 1
6: 0 1 1 2 3 5 2 1 3 4 1 5 0 5 5 4 3 1 4 5 3 2 5 1
7: 0 1 1 2 3 5 1 6 0 6 6 5 4 2 6 1
8: 0 1 1 2 3 5 0 5 5 2 7 1
9: 0 1 1 2 3 5 8 4 3 7 1 8 0 8 8 7 6 4 1 5 6 2 8 1
10: 0 1 1 2 3 5 8 3 1 4 5 9 4 3 7 0 7 7 4 1 5 6 1 7 8 5 3 8 1 9 0 9 9 8 7 5 2 7 9 6 5 1 6 7 3 0 3 3 6 9 5 4 9 3 2 5 7 2 9 1
11: 0 1 1 2 3 5 8 2 10 1
12: 0 1 1 2 3 5 8 1 9 10 7 5 0 5 5 10 3 1 4 5 9 2 11 1
13: 0 1 1 2 3 5 8 0 8 8 3 11 1 12 0 12 12 11 10 8 5 0 5 5 10 2 12 1
14: 0 1 1 2 3 5 8 13 7 6 13 5 4 9 13 8 7 1 8 9 3 12 1 13 0 13 13 12 11 9 6 1 7 8 1 9 10 5 1 6 7 13 6 5 11 2 13 1
15: 0 1 1 2 3 5 8 13 6 4 10 14 9 8 2 10 12 7 4 11 0 11 11 7 3 10 13 8 6 14 5 4 9 13 7 5 12 2 14 1
16: 0 1 1 2 3 5 8 13 5 2 7 9 0 9 9 2 11 13 8 5 13 2 15 1
17: 0 1 1 2 3 5 8 13 4 0 4 4 8 12 3 15 1 16 0 16 16 15 14 12 9 4 13 0 13 13 9 5 14 2 16 1
18: 0 1 1 2 3 5 8 13 3 16 1 17 0 17 17 16 15 13 10 5 15 2 17 1
19: 0 1 1 2 3 5 8 13 2 15 17 13 11 5 16 2 18 1
20: 0 1 1 2 3 5 8 13 1 14 15 9 4 13 17 10 7 17 4 1 5 6 11 17 8 5 13 18 11 9 0 9 9 18 7 5 12 17 9 6 15 1 16 17 13 10 3 13 16 9 5 14 19 13 12 5 17 2 19 1
21: 0 1 1 2 3 5 8 13 0 13 13 5 18 2 20 1
22: 0 1 1 2 3 5 8 13 21 12 11 1 12 13 3 16 19 13 10 1 11 12 1 13 14 5 19 2 21 1
23: 0 1 1 2 3 5 8 13 21 11 9 20 6 3 9 12 21 10 8 18 3 21 1 22 0 22 22 21 20 18 15 10 2 12 14 3 17 20 14 11 2 13 15 5 20 2 22 1
24: 0 1 1 2 3 5 8 13 21 10 7 17 0 17 17 10 3 13 16 5 21 2 23 1
25: 0 1 1 2 3 5 8 13 21 9 5 14 19 8 2 10 12 22 9 6 15 21 11 7 18 0 18 18 11 4 15 19 9 3 12 15 2 17 19 11 5 16 21 12 8 20 3 23 1 24 0 24 24 23 22 20 17 12 4 16 20 11 6 17 23 15 13 3 16 19 10 4 14 18 7 0 7 7 14 21 10 6 16 22 13 10 23 8 6 14 20 9 4 13 17 5 22 2 24 1
26: 0 1 1 2 3 5 8 13 21 8 3 11 14 25 13 12 25 11 10 21 5 0 5 5 10 15 25 14 13 1 14 15 3 18 21 13 8 21 3 24 1 25 0 25 25 24 23 21 18 13 5 18 23 15 12 1 13 14 1 15 16 5 21 0 21 21 16 11 1 12 13 25 12 11 23 8 5 13 18 5 23 2 25 1
27: 0 1 1 2 3 5 8 13 21 7 1 8 9 17 26 16 15 4 19 23 15 11 26 10 9 19 1 20 21 14 8 22 3 25 1 26 0 26 26 25 24 22 19 14 6 20 26 19 18 10 1 11 12 23 8 4 12 16 1 17 18 8 26 7 6 13 19 5 24 2 26 1
28: 0 1 1 2 3 5 8 13 21 6 27 5 4 9 13 22 7 1 8 9 17 26 15 13 0 13 13 26 11 9 20 1 21 22 15 9 24 5 1 6 7 13 20 5 25 2 27 1
29: 0 1 1 2 3 5 8 13 21 5 26 2 28 1
30: 0 1 1 2 3 5 8 13 21 4 25 29 24 23 17 10 27 7 4 11 15 26 11 7 18 25 13 8 21 29 20 19 9 28 7 5 12 17 29 16 15 1 16 17 3 20 23 13 6 19 25 14 9 23 2 25 27 22 19 11 0 11 11 22 3 25 28 23 21 14 5 19 24 13 7 20 27 17 14 1 15 16 1 17 18 5 23 28 21 19 10 29 9 8 17 25 12 7 19 26 15 11 26 7 3 10 13 23 6 29 5 4 9 13 22 5 27 2 29 1

A quine is a program that prints itself. This uses inside knowledge of that your program compiles to a function. The 2^nd echo decompiles and pretty-prints it. Because grep consumes its return value, it returns it, instead of printing. It replaces surrounding boilerplate by pl ''. Both the long and short form are quines:

pl 'echo grep({tr/\n / /s; s/.*: \{ /pl $quote/u; s/; \}.*/$quote/u;} echo(__SUB__))'

pl 'e grep({tr/\n / /s; s/.*: \{ /pl $q/u; s/; \}.*/$q/u;} e(__SUB__))'

pl 'echo grep({tr/\n / /s; s/.*: \{ /pl $quote/u; s/; \}.*/$quote/u;} echo(__SUB__))'
pl 'e grep({tr/\n / /s; s/.*: \{ /pl $q/u; s/; \}.*/$q/u;} e(__SUB__))'

Even though decompilation rarely comes up as a quine no-go, indirectly the above does read its source. You might consider it a cheating quine. To placate those who think so, here's a constructive way of doing it, with a format string that implicitly gets fed to itself:

pl '$_ = q{$_ = q{%s}; form "pl $quote$_$quote"}; form "pl $quote$_$quote"'

pl '$_ = q{$_ = q{%s}; f "pl $q$_$q"}; f "pl $q$_$q"'

pl '$_ = q{$_ = q{%s}; form "pl $quote$_$quote"}; form "pl $quote$_$quote"'
pl '$_ = q{$_ = q{%s}; f "pl $q$_$q"}; f "pl $q$_$q"'

Golf: Quine The same approach but without adding pl '', so this works only in the pl-Shell, which you start by calling pl without arguments. The shortest Perl quine inspired this most compact variant. We beat it by 6 characters in the short form. That uses x2 to duplicate the argument to the pre-prototypes printf. But form has a prototype. Use the old &-syntax to prevent that giving 2 (the length of the list):

&form(qw(&form(qw(%s)x2))x2)

&f(qw(&f(qw(%s)x2))x2)

&form(qw(&form(qw(%s)x2))x2)
&f(qw(&f(qw(%s)x2))x2)