Anonymous user
Algebraic data types: Difference between revisions
Added Perl Implementation
(Changed Pilog Lisp call syntax (since 3.1.3.5)) |
(Added Perl Implementation) |
||
Line 479:
t(b A Y B)
end</lang>
=={{header|Perl}}==
{{works with|Perl|5.010}}
Although Perl does not have algebraic data types, it does have a wonderfully flexible regular expression engine, which is powerfully enough to perform the task.
However, representing a tree as a string, and repeatedly parsing that string, is truly inefficient way to solve the problem. Someday, someone will write a perl multi-method-dispatch module which is as amazing as perl6's, and then we can copy the perl6 solution here.
The $balanced variable matches against either some data, or the empty tree (_), or, using perl's amazing recursive regular expression feature, a non-empty tree.
Each of the single letter variables declared right after $balanced, match an instance of $balanced, and if they succeed, store the result into the %+ hash.
<lang perl>#!perl
use 5.010;
use strict;
use warnings qw(FATAL all);
my $balanced = qr{([^<>,]++|<(?-1),(?-1),(?-1),(?-1)>)};
my ($a, $b, $c, $d, $x, $y, $z) = map +qr((?<$_>$balanced)),
'a'..'d', 'x'..'z';
my $col = qr{(?<col>[RB])};
sub balance {
local $_ = shift;
if( /^<B,<R,<R,$a,$x,$b>,$y,$c>,$z,$d>\z/ or
/^<B,<R,$a,$x,<R,$b,$y,$c>>,$z,$d>\z/ or
/^<B,$a,$x,<R,<R,$b,$y,$c>,$z,$d>>\z/ or
/^<B,$a,$x,<R,$b,$y,<R,$c,$z,$d>>>\z/ )
{
my ($aa, $bb, $cc, $dd) = @+{'a'..'d'};
my ($xx, $yy, $zz) = @+{'x'..'z'};
"<R,<B,$aa,$xx,$bb>,$yy,<B,$cc,$zz,$dd>>";
} else {
$_;
}
}
sub ins {
my ($xx, $tree) = @_;
if($tree =~ m{^<$col,$a,$y,$b>\z} ) {
my ($color, $aa, $bb, $yy) = @+{qw(col a b y)};
if( $xx < $yy ) {
return balance "<$color,".ins($xx,$aa).",$yy,$bb>";
} elsif( $xx > $yy ) {
return balance "<$color,$aa,$yy,".ins($xx,$bb).">";
} else {
return $tree;
}
} elsif( $tree !~ /,/) {
return "<R,_,$xx,_>";
} else {
print "Unexpected failure!\n";
print "Tree parts are: \n";
print $_, "\n" for $tree =~ /$balanced/g;
exit;
}
}
sub insert {
my $tree = ins(@_);
$tree =~ m{^<$col,$a,$y,$b>\z} or die;
"<B,$+{a},$+{y},$+{b}>";
}
MAIN: {
my @a = 1..10;
for my $aa ( 1 .. $#a ) {
my $bb = int rand( 1 + $aa );
@a[$aa, $bb] = @a[$bb, $aa];
}
my $t = "!";
for( @a ) {
$t = insert( $_, $t );
print "Tree: $t.\n";
}
}
print "Done\n";
</lang>
{{out}}
<pre>Tree: <B,_,9,_>.
Tree: <B,<R,_,7,_>,9,_>.
Tree: <B,<B,_,2,_>,7,<B,_,9,_>>.
Tree: <B,<B,_,2,<R,_,6,_>>,7,<B,_,9,_>>.
Tree: <B,<B,_,2,<R,_,6,_>>,7,<B,_,9,<R,_,10,_>>>.
Tree: <B,<R,<B,_,2,_>,5,<B,_,6,_>>,7,<B,_,9,<R,_,10,_>>>.
Tree: <B,<R,<B,_,2,<R,_,4,_>>,5,<B,_,6,_>>,7,<B,_,9,<R,_,10,_>>>.
Tree: <B,<R,<B,_,2,<R,_,4,_>>,5,<B,_,6,_>>,7,<B,<R,_,8,_>,9,<R,_,10,_>>>.
Tree: <B,<R,<B,<R,_,1,_>,2,<R,_,4,_>>,5,<B,_,6,_>>,7,<B,<R,_,8,_>,9,<R,_,10,_>>>.
Tree: <B,<B,<B,<R,_,1,_>,2,_>,3,<B,_,4,_>>,5,<B,<B,_,6,_>,7,<B,<R,_,8,_>,9,<R,_,10,_>>>>.
Done</pre>
=={{header|Perl 6}}==
{{works with|Rakudo|2012.05}}
| |||