This is my response to the Perl Weekly Challenge #094.
@S.
Input: ("opt", "bat", "saw", "tab", "pot", "top", "was")
Output: [ ("bat", "tab"),
("saw", "was"),
("top", "pot", "opt") ]
Input: ("x")
Output: [ ("x") ]
This is similar to Perl Weekly Challenge #038.2: Word Game.
The program presented below is based on my «wordgame» program. See my article Datefinder General, A Raku Wordgame for a detailed description.
We need a dictionary to decide check if the candidates really are anagrams (existing words in their own right). I have three dictionaries on my Ubuntu box, and we can let the user decide which of them (or any other for that matter) to use:
#! /usr/bin/env raku
unit sub MAIN (*@S, # [1]
:$dictionary where $dictionary.IO.r
= "/usr/share/dict/british-english"); # [2]
@S = <opt bat saw tab pot top was> unless @S; # [3]
my %dict = $dictionary.IO.lines.grep(* !~~ /\W/).Set; # [4]
my %seen; # [5]
my @lines; # [6]
for @S -> $word # [7]
{
my $sorted = $word.comb.sort.join; # [8]
next if %seen{$sorted}; # [9]
%seen{$sorted} = True; # [10]
@lines.push: "(" ~ $word.comb.permutations>>.join.unique
# 11 ##### 18 # # 12 ################## # 13 # # 14 #
.grep({ %dict{$_} }).map({ '"' ~ $_ ~ '"' }).join(", ") ~ ")";
# 15 ############## # 16 ################## # 17 ##### # 18
}
say "[ ", @lines.join(",\n"), " ]"; # [19]
[1] A slurpy argument cannot have a default value, so we have to fix that separately (see [3]).
[2] We dafult to the english dictionary.
[3] The default list of words.
[4] Skip words that contain non-word (\W) characters.
The English (and American) dictionary contains a lot of apostrophes, and we ignore
those words. The result is a Set (.Set) - a hash variety where the value
is True. Looking up a non-existing key gives False.
[5] Words we have seen already, so that we can skip duplicates on the command line.
[6] The result, line for line so that we can get the parens, quotes and commas right.
[7] For each word in the input,
[8] Split it init individual letters, sort them, and join them back to a string.
[9] Skip the word if we have seen it already.
[10] We have seen it now.
[11] Add a line for each input word, by:
[12] • Get all the permutations of the word (as a list of letters).
[13] • Join the individual permutations together to strings.
[14] • Get rid of duplicates, if any.
[15] • Get rid of string that does not occur in the dictionary.
[16] • Add single quotes (apostropes) around the words.
[17] • Join the perumations with commas,
[18] • The opening and closing parens.
[19] Print the brackets, and the lines with commas between them.
See
docs.raku.org/routine/Set for
more information about the Set method.
Running it:
$ ./group-anagrams
[ ("opt", "pot", "top"),
("bat", "tab"),
("saw", "was") ]
We get the same result with the American dictionary:
$ ./group-anagrams --dictionary="/usr/share/dict/american-english"
[ ("opt", "pot", "top"),
("bat", "tab"),
("saw", "was") ]
The German dictionary actually works out, sort of:
$ ./group-anagrams --dictionary="/usr/share/dict/ngerman"
[ (),
("bat"),
("was") ]
We can get rid of the empty list on the first line:
File: group-anagrams2 (changes only)
say "[ ", @lines.grep(*.chars > 2).join(",\n"), " ]"; # [1]
[1] The lines are given as strings here, so we just sort out strings with length 2
(or less). Two characters is what we get for an empty list, as ().
Running it:
./group-anagrams2 --dictionary="/usr/share/dict/ngerman"
[ ("bat"),
("was") ]
Input:
1
/ \
2 3
/ \
4 5
/ \
6 7
Output:
1 -> 2 -> 4 -> 5 -> 6 -> 7 -> 3
We did the first part of this challenge, specifying and building up a binary tree, last week (in Perl Weekly Challenge #093.2: Sum Path).
See my article Pointy Path with Raku (and the «sum-path» program) for details.
Or you could go to the source, Perl Weekly Challenge #056.2: Path Sum and my article Diff Sum by Raku (and the «path-sum-conf2» program), for even more details.
I forgot to point out in last week's artcicle that the three building is done bottom up, so that we do not have to change the pointers after object creation. And the pointers are indeed read only (after object creation) because of this.
The first part of the program has been copied without change, except the default tree, and is not explained here.
File: btree2linkedlist (partial)
#! /usr/bin/env raku
unit sub MAIN (Str $tree = "1 | 2 3 | 4 5 | * * 6 7", :v(:$verbose));
class BinaryNode
{
has Int $.value;
has BinaryNode $.left;
has BinaryNode $.right;
}
my @btree = $tree.split("|")>>.words;
my @old-nodes;
my @new-nodes;
for @btree.reverse -> $row
{
my @current = @$row;
@old-nodes = @new-nodes;
@new-nodes = ();
for @current -> $value
{
if $value eq "*"
{
@new-nodes.push("*");
next;
}
my $left = @old-nodes.shift // "*"; $left = Nil if $left eq "*";
my $right = @old-nodes.shift // "*"; $right = Nil if $right eq "*";
@new-nodes.push(BinaryNode.new(value => $value.Int,
left => $left // Nil,
right => $right // Nil));
}
}
my $btree = @new-nodes[0];
say ": { $btree.raku }" if $verbose;
Then we get to the linked list, whee I have chosen to set up a class similar to «BinaryNode», except that it does only have one child. The object construction is done left to right this time (just for fun), so we have to change the pointers after object creation.
File: btree2linkedlist (partial)
class UnaryNode
{
has Int $.value;
has UnaryNode $.child is rw; # [1]
method show # [2]
{
print self.value; # [2a]
if self.child { print " -> "; self.child.show; } # [2b]
else { say ""; } # [2c]
}
}
[1] The is rw trait is used so that we can change the value after
object creation.
[2] This method will print the value of the current node [2a], and all its children recursively with an arrow between the values [2b]. Note the final newline [2c].
See
docs.raku.org/routine/is rw for
more information about the is rw trait.
The part where we traverse the binary tree and set up the linked list:
File: btree2linkedlist (the rest)
my $linked-list; # [3]
my $ll-current; # [4]
traverse($btree); # [5]
say ": { $linked-list.raku }" if $verbose;
$linked-list.show; # [6]
sub traverse ($current) # [7]
{
my $node = UnaryNode.new(value => $current.value); # [8]
$linked-list
?? ( $ll-current.child = $node ) # [9]
!! ( $linked-list = $node ); # [10]
$ll-current = $node; # [11]
traverse($current.left) if $current.left; # [12]
traverse($current.right) if $current.right; # [13]
}
[3] The linked list (the left most element).
[4] The current element (actually the last) in the linked list, as we build it.
[5] Traverse the binary tree.
[6] Show the linked list.
[7] Off we go, recursively. Note input parameter, a binary tree node.
[8] Create a new linked list element.
[9] Do we have a linked list already (i.e. this is not the first element)? Yes: set the current pointer.
[10] No: Set the list pointer.
[11] Atatch the new node to the end of the list. Note that this does not do anything (useful, or otherwise) if this is the very first node we create.
[12] Follow the left child, if the current node has a left child.
[13] Ditto for the right child.
Running it:
$ ./btree2linkedlist
1 -> 2 -> 4 -> 5 -> 6 -> 7 -> 3
$ ./btree2linkedlist "1 | 2 3 | 4 5 6 7 | 8 9 10 11"
1 -> 2 -> 4 -> 8 -> 9 -> 5 -> 10 -> 11 -> 3 -> 6 -> 7
With verbose mode (and newlines and indentation added for readability):
$ ./btree2linkedlist -v
: BinaryNode.new(value => 1,
left => BinaryNode.new(value => 2,
left => BinaryNode.new(value => 4,
left => BinaryNode,
right => BinaryNode
),
right => BinaryNode.new(value => 5,
left => BinaryNode.new(value => 6,
left => BinaryNode,
right => BinaryNode
),
right => BinaryNode.new(value => 7,
left => BinaryNode,
right => BinaryNode
)
)
),
right => BinaryNode.new(value => 3,
left => BinaryNode,
right => BinaryNode
)
)
: UnaryNode.new(value => 1,
child => UnaryNode.new(value => 2,
child => UnaryNode.new(value => 4,
child => UnaryNode.new(value => 5,
child => UnaryNode.new(value => 6,
child => UnaryNode.new(value => 7,
child => UnaryNode.new(value => 3,
child => UnaryNode
)
)
)
)
)
)
)
1 -> 2 -> 4 -> 5 -> 6 -> 7 -> 3
Looking good.
And that's it.