Algebraic data types: Difference between revisions
Content added Content deleted
(Changed Pilog Lisp call syntax (since 3.1.3.5)) |
(Added Perl Implementation) |
||
Line 479: | Line 479: | ||
t(b A Y B) |
t(b A Y B) |
||
end</lang> |
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}}== |
=={{header|Perl 6}}== |
||
{{works with|Rakudo|2012.05}} |
{{works with|Rakudo|2012.05}} |