Perlでパーサーコンビネータもどき
HaskellのMonadをJavaScriptで実装するとしたら - ラシウラ
を参考にほとんど写経.
#!/usr/bin/env perl use strict; use warnings; sub parse { my ($parser, $input) = @_; return $parser->({ result => [], source => $input, index => 0, }); } sub bind { my ($src, $dst) = @_; return sub { my $pstate = shift; my $nstate = $src->($pstate); return &fail($nstate) unless $nstate; return $dst->($nstate->{result})->($nstate); }; } sub return { my $value = shift; return sub { my $pstate = shift; my $nstate; %$nstate = %$pstate; $nstate->{result} = $value; return $nstate; }; } sub fail { return; } sub char { my $ch = shift; return sub { my $pstate = shift; if (substr($pstate->{source}, $pstate->{index}, 1) eq $ch) { my $nstate; %$nstate = %$pstate; $nstate->{index} = $pstate->{index} + 1; $nstate->{result} = $ch; return $nstate; } else { &fail; } } } sub many { my $parser = shift; return sub { my $pstate = shift; my $current = $pstate; my $result; for(;;) { my $next = $parser->($current); if ($next) { $result .= $next->{result}; $current = $next; } else { my $nstate; %$nstate = %$current; $nstate->{result} = $result; return $nstate; } } }; } sub orelse { my ($p1, $p2) = @_; return sub { my $pstate = shift; return $p1->($pstate) || $p2->($pstate); }; }
実行例
my $manydParser = many(&bind(char('d'), sub { my $a = shift; return &return($a); })); my $abcParser = &bind(char('a'), sub { my $a = shift; &bind(char('b'), sub { my $b = shift; &bind(char('c'), sub { my $c = shift; &return($a . $b . $c); }); }); }); print parse($manydParser, "ddda") ->{result}, "\n"; # "ddd" print parse($abcParser, "abcd") ->{result}, "\n"; # "abc" print parse($abcParser, "abd"), "\n"; # undef print parse(orelse($abcParser, $manydParser), "ddabd")->{result}, "\n"; # "dd"
スターがついてる
こんなに嬉しいとは思わなかった.
Project Euler Problem61
Perlの練習ということで
#!/usr/bin/perl use strict; use warnings; my @paths; $paths[$_] = [] for(0..99); push(@{$paths[target($_)]}, [{8 => 1}, [source($_), target($_)]]) for (polygonals(8)); for(3..7) { my @prev = @paths; $paths[$_] = [] for(0..99); foreach my $n (3..7) { foreach my $p (polygonals($n)) { foreach (@{$prev[source($p)]}) { unless($_->[0]->{$n}) { push (@{$paths[target($p)]}, [{%{$_->[0]}, $n => 1} , [@{$_->[1]}, target($p)]]); } } } } } foreach (@paths) { foreach (@$_) { if ($_->[1]->[0] == $_->[1]->[6]) { my $ans = 0; for (my $i = 0; $i < 6; $i++) {$ans += 101 * $_->[1]->[$i];} print "$ans\n"; } } } sub polygonals { my $n = shift; my @ret; my $p = 0; my $k = 0; while($p < 10000) { push @ret, $p if $p >= 1000 and source($p) >= 10 and target($p) >= 10; $p = polygonal($n, $k++); } return @ret } sub source { return int($_[0] / 100); } sub target { return $_[0] % 100; } sub polygonal { my $k = shift; my $n = shift; return $n*(($k-2)*$n-$k+4)/2; }
なんか気持ち悪い.
明日Perlの本借りる.
はてなインターンにいきたいので
日記を書く.