99 Problems in Perl6

[Ovid]

I recently stumbled across 99 Lisp Problems (which was originally 99 Prolog Problems). It looked like fun, so I started answering those problems in Perl 6. This has shown me that I don't know Perl 6 nearly as well as I would like. However, here are my first 9 answers:

#!/usr/bin/pugs

use v6-alpha;

#P01 (*) Find the last box of a list.
#    Example:
#    * (my-last '(a b c d))
#    (D)

<a b c d>[-1].say;

#P02 (*) Find the last but one box of a list.
#    Example:
#    * (my-but-last '(a b c d))
#    (C D)

<a b c d>[-2, -1].perl.say;

#P03 (*) Find the K'th element of a list.
#    The first element in the list is number 1.
#    Example:
#    * (element-at '(a b c d e) 3)
#    C

<a b c d>[2].perl.say;

#P04 (*) Find the number of elements of a list.

<a b c d>.elems.say;

#P05 (*) Reverse a list.

<a b c d>.reverse.perl.say;

#P06 (*) Find out whether a list is a palindrome.
#    A palindrome can be read forward or backward; e.g. (x a m a x).

for [<a b c b a>], [<a b c b c a>] -> $array {
    if $array.reverse ~~ $array {
        say $array.perl ~ " is a palindrome";
    }
    else {
        say $array.perl ~ " is not a palindrome";
    }
}

#P07 (**) Flatten a nested list structure.
#    Transform a list, possibly holding lists as elements into a `flat
+' list by
#    replacing each list with its elements (recursively).


# courtesy of Wim Vanderbauwhede from the perl6-users list
my $flatten = -> $x { $x.isa(Array) ?? ( map $flatten, $x ) !! $x }; 
my @flattened = map $flatten, ('a', ['b', ['c', 'd', 'e']]);
@flattened.perl.say;

#P08 (**) Eliminate consecutive duplicates of list elements.
#    If a list contains repeated elements they should be replaced with
+ a single
#    copy of the element. The order of the elements should not be chan
+ged.

#    Example:
#    * (compress '(a a a a b c c a a d e e e e))
#    (a b c a d E)

my $compress = do {
    my $previous;
    $compress = sub ($x) {
        if $x ne $previous {
            $previous = $x;
            return $x;
        }
        else {
            return;
        }
    };
}
my @compressed = map $compress, <a a a a b c c a a d e e e e>;
@compressed.perl.say;

#P09 (**) Pack consecutive duplicates of list elements into sublists.
#    If a list contains repeated elements they should be placed in sep
+arate sublists.
#
#    Example:
#    * (pack '(a a a a b c c a a d e e e e))
#    ((A A A A) (B) (C C) (A A) (D) (E E E E))

my @packed;
{
    my @sublist;
    my $previous;
    for <a a a a b c c a a d e e e e> -> $x {
        if $x eq $previous {
            @sublist.push($x);
            next;
        }
        $previous = $x;
        if @sublist {
            @packed.push([@sublist]);
            @sublist = $x;
        }
    }
    @packed.push([@sublist]);
}
@packed.perl.say;

Needless to say, I have a lot more work to do, but feel free to tackle them. You should probably read the latest Perl6 docs.

All of the above examples run under the latest version of Pugs.

Hint for problem 10: it's very, very close to problem 9.

Problem 10: Run-length encoding of a list.
Use the result of problem P09 to implement the so-called run-length encoding data compression method. Consecutive duplicates of elements are encoded as lists (N E) where N is the number of duplicates of the element E.

Example:
* (encode '(a a a a b c c a a d e e e e))
((4 A) (1 B) (2 C) (2 A) (1 D)(4 E))

Update: Swapped POD for comments to make it shorter and easier to read. Also, if you struggle with a problem, try writing it in Perl 5 first.

[Ovid]

How embarrassing. My first version of problem 9 (packing lists into sublists) had a bug. Here's a cleaner version which actually works. I know the bug in problem 9. Can you spot it?

sub pack (@array) returns Array {
    my @unpacked = @array;
    my (@list, @packed);
    while @unpacked {
        @list.push(@unpacked.shift) while !@list || @list[0] eq @unpac
+ked[0];
        @packed.push([@list]);
        @list = ();
    }
    return @packed;
}
pack(<a a a a b c c a a d e e e e>).perl.say;

And for the Lisp weenies who claim Lisp is so much better, here's one way to do it in Lisp (can you make it shorter?):

(defun pack (lista)
    (if (eql lista nil) 
        nil
        (cons (pega lista) (pack (tira lista)))
    )
)

(defun pega (lista)
    (cond ((eql lista nil) nil)
      ((eql (cdr lista) nil) lista)
          ((equal (car lista) (cadr lista))
              (cons (car lista) (pega (cdr lista))))
          (t (list (car lista)))
    )
)

(defun tira (lista)
    (cond ((eql lista nil) nil)
      ((eql (cdr lista) nil) nil)
          ((equal (car lista) (cadr lista))
              (tira (cdr lista)))
          (t (cdr lista))
    )
)

But the Prolog folks still have a neat solution:

pack([],[]).
pack([X|Xs],[Z|Zs]) :- transfer(X,Xs,Ys,Z), pack(Ys,Zs).

transfer(X,[],[],[X]).
transfer(X,[Y|Ys],[Y|Ys],[X]) :- X \= Y.
transfer(X,[X|Xs],Ys,[X|Zs]) :- transfer(X,Xs,Ys,Zs).

And Haskell still makes us all look like chumps:

group (x:xs) = let (first,rest) = span (==x) xs
               in (x:first) : group rest
group [] = []

[TimToady]

Here's a prettier way to write the Perl 6 solution:

sub group (*@array is copy) {
    gather {
        while @array {
            take [
                gather {
                    my $h = shift @array;
                    take $h;
                    while @array and $h eq @array[0] {
                        take shift @array;
                    }
                }
            ];
        }
    }
}

It would be slightly prettier if take could harvest a value en passant.

[Ovid]

Sweet!

Why do you flatten the array? I played with that in Pugs and the asterisk seems superfluous. It seems like one is copy the elements and the other is copying the array. I thought that maybe your version would avoid aliasing problems, but even in checking that, I'm not seeing it happening.

sub group (@array is copy) {   # didn't flatten
    gather {
        while @array {
            take [
                gather {
                    my $h = shift @array;
                    take $h;
                    while @array and $h eq @array[0] {
                        take shift @array;
                    }
                }
            ];
        }
    }
}

[Anonymous Monk]

atoku says: Lisp deserves better code :) Below is just an example of a possible better way ;) just 6 lines.

(defun pick-new (lst el)
  (if (eql (car (car lst)) el)
      (cons (cons el (car lst)) (cdr lst))
      (cons (list el) lst)))

(defun pack (lst)
  (reverse (reduce #'pick-new lst :initial-value nil)))

Winston Smith says: Here is a variation on Atoku’s elegant lisp solution. Note the unification of cases made possible by the side-effect of pop.

(defun pick-new (lst el)
  (cons (cons el (when (equal el (caar lst)) (pop lst))) lst))

(defun pack (lst)
  (reverse (reduce #'pick-new lst :initial-value nil)))

Here are three solutions in lisp that don’t require auxiliary functions.

;;With loop:

(defun pack(lst &optional groups)
  (loop for el in lst 
        for first-group = (when (equal el (caar groups)) (pop groups))
        do (push (cons el first-group) groups))
  (reverse groups))

;;With recursion:

(defun pack(lst &optional groups)
  (if (not lst) (reverse groups) 
      (let* ((el (pop lst))
             (first-group (when (equal el (caar groups)) (pop groups))
+))
        (pack lst (cons (cons el first-group) groups)))))

;;With no mercy:

(defun pack(lst &optional g)
  (if (not lst) (reverse g) 
      (pack (cdr lst) (cons (cons (car lst) (when (equal (car lst) (ca
+ar g)) (pop g))) g)))))

[BrowserUk]

Seems that most of the Perl 6 solutions (never mind the hidious lisp concoctions:) are much clumsier than a fairly obvious Perl 5 solution?

Updated: To correctly handle a null list per TimToady's correction below.

sub p09{
@_?reduce{$a->[-1][0]eq$b?push@{$a->[-1]},$b:push@{$a},[$b];$a;}[[shif
+t]],@_:()
}

which could almost certainly be golfed further, but for the queasy, expands out to a relatively clean:

use List::Util qw[ reduce ];
sub p09 { 
    @_ ? reduce{ 
          $a->[-1][0] eq $b 
             ? push @{ $a->[ -1 ] }, $b 
             : push @{ $a }, [ $b ]; 
          $a; 
    } [[shift]], @_ 
    :()
}

[TimToady]

Minor quibble: that would appear to generate a different result when you feed it the null list.

[BrowserUk]

Good catch++. Updated.

[gaal]

In #8, you have a superfluous assignment of the closure. Instead of

my $compress = do {
    my $previous;
    $compress = sub ($x) { ... }
};

You could just arrange for the sub definition to be the last evaluated thing inside the do. (This is really no different from Perl 5, except for the formal parameter.)

my $compress = do {
    my $previous;
    sub ($x) { ... }
};

# or perhaps,

my $compress;
{
    my $previous;
    $compress = sub ($x) { ... }
}

[gaal]

On second thought, the only reason you have a closure here at all is to preserve state between calls. Use a state variable then, and the more normal function definition syntax.

sub compress ($x) {
    state $previous;
    if $x ne $previous {
        return $x;
    }
    else {
        return;
    }
}

Update: I think the if is way too long, but can't remember if there's a context-safe way to return nothing in Perl 6 (that isn't "fail"), to golf out the "return" and say something like return $x ne $previous ?? $x !! $NOTHING_AT_ALL;. In the current application () is probably safe.

[Ovid]

You know, we're getting pretty close to the terseness of Haskell, but (I think) it's still rather readable:

my $compress = sub ($x) {
    state $previous;
    $x ne $previous ?? $previous = $x !! return;
}

And in Haskell:

compress :: Eq a => [a] -> [a]
compress = map head . group

Update: as concise, but less "golfy":

my $compress = sub ($x) {
    state $previous;
    return $x ne $previous ?? $previous = $x !! ();
}

[Ovid]

Good points, thank you. I suppose if I really want to confuse people (again, pretty darned close to Perl 5):

my $compress = do {
    my $previous;
    sub ($x) {
        $x ne $previous ?? $previous = $x !! return;
    };
}

That works just fine, but it might give someone pause :) Of course, I wouldn't write it like that for production.

[tye]

I thought I read recently that in Perl 6, this:

... ?? $previous = $x !! ...;

would be a syntax error. You need parens (I think Pugs lets you get away with this for now but that will get fixed eventually).

[eric256]

Couldn't that be done easier with take/gather?

my @in = <a a a a b c c a a d e e e e>;
my @out = gather {
        for  @in -> $i {
            state $last;
            take $i if $i ne $last;
            $last = $i;
        }};
say @out;

[gaal]

TIMTOWTDI of course, but syntax updates to gather since the OP allow you to write it as:

my @in = <a a a a b c c a a d e e e e>;
say gather for @in -> $i {
    state $last;
    $last = take $i if $i ne $last;
};

[jdporter]

@flattened.perl.say;

What is this .perl method? Needless to .say, it's not easy to search for.

[Ovid]

It's kind of like a poor man's Data::Dumper. For example, if you want to see all of your environment variables, you can use this:

%*ENV.perl.say;

That will represent %*ENV (remember that the '*' twigil means it's global) in a way that's legal Perl6 code. I use it because it makes complex data structures much easier to read. I don't know if it's possible to customize the output, though. Right now it's all one one line.

You can still do this:

%*ENV.say;

You won't find the output as legible, though.

And while we're on the topic of environment variables, use the '+' twigil to read them. What to see the 'HOME' environment variable?

$+HOME.say

Update: the one thing I really want is for reflection to be added to Pugs so I can query an object for its methods. That will be a huge productivity boost so we can see exactly what we can play with.

[gaal]

What Ovid said. There's also a .yaml method that does the YAML::Syck::Dump equivalent. The round trip is also analogous:

eval $obj.perl;
eval $obj.yaml :lang<yaml>;     # though this syntax is unspecced and 
+may change.

[Util]

From S02:

To get a Perlish representation of any object, use the .perl method. Like the Data::Dumper module in Perl 5, the .perl method will put quotes around strings, square brackets around list values, curlies around hash values, constructors around objects, etc., so that Perl can evaluate the result back to the same object.

[perrin]

"If you're having perl problems I feel bad for you son,
I got 99 problems but Perl 6 ain't one"

Sorry, I couldn't resist.

[stonecolddevin]

The Jigga Man has spoken :-)

[Juerd]

Why say everything?

[Ovid]

Well, to be honest, I should write tests instead, but this was a quick start to just show the answers. By doing it this way, we don't have to worry about explaining "this is how you test code", but I suppose it would be better that way.

[Util]

Here are my solutions to Problem 9. The first is concise and looks fairly efficient. The second is less straightforward; I wanted to solve it with one big map, in the hopes of allowing it to work lazily. I don't know how to tell if I succeeded, though.

Code tested in Pugs:

sub p09_group_Util_1 (*@list) {
    my @ret;
    for @list -> $val {
        push @ret, [] if !@ret or $val !~~ @ret[-1][-1];
        push @ret[-1], $val;
    }
    return @ret;
}
sub p09_group_Util_2 (*@list) {
    my @tmp;
    return map -> $index, $val {
        my @ret;
        if !@tmp or $val !~~ @tmp[-1] {
            @ret = [ @tmp ] if @tmp;
            undefine @tmp;
        }
        push @tmp, $val;
        push @ret, [ @tmp ] if @tmp and $index == @list.end;
        @ret; # May contain 0, 1, or 2 arrayrefs.
    }, @list.kv;
}

my @data = <a a a a b c c a a d e e e e>;
say '9.1 ', p09_group_Util_1(@data).perl;
say '9.2 ', p09_group_Util_2(@data).perl;
# When dumped via .perl, Util_1 is wrapped in [], and Util_2 in ().
# When dumped via .yaml, Util_1 and Util_2 are identical. Bug?

Output:

9.1 [["a", "a", "a", "a"], ["b",], ["c", "c"], ["a", "a"], ["d",], ["e
+", "e", "e", "e"]]
9.2 (["a", "a", "a", "a"], ["b",], ["c", "c"], ["a", "a"], ["d",], ["e
+", "e", "e", "e"])