Language detail: Perl
Coverage: 97.87%
|
number of '+' ratings |
contribution for coverage |
Unsolved challenges
codes
π
(Nested
Flatten)
とりあえず、参考ページにあった数式で素直に計算。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | use strict;
use warnings;
use bignum;
use List::Util qw/reduce/;
use Memoize;
sub fract
{
$_[0] == 0 || $_[0] == 1 ? 1 :
$_[0] * fract($_[0]-1);
}
memoize(q/fract/);
my $N = 32;
print 6 * reduce {
no warnings qw/once/;
$a + $b
} map {
fract(2 * $_) /
((2 ** (4 * $_ + 1)) * (fract($_) ** 2) * (2 * $_ + 1))
} 0 .. $N;
|
タブ区切りデータの処理
(Nested
Flatten)
標準入力から読込 標準出力への出力
1 2 3 4 5 | @header = split(/\t/, <>);
($header[2], $header[1]) = ($header[1], $header[2]);
print join("\t", @header);
print map { ($_->[2], $_->[1])=($_->[1], $_->[2]);$_->[3]++; join("\t", @$_)."\n"; } sort{ $a->[0] <=> $b->[0] } map [split /\t/], <> ;
|
数値リストの圧縮
(Nested
Flatten)
#7713 をperlに移植した感じになりました。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | use strict;
use warnings;
my @list = (1, 3, 4, 5, 6, 12, 13, 15, 20, 25, 26, 27);
my $prevd = $list[0];
my @result = ([+$list[0]]);
for (my $idx = 1; $idx < @list; ++$idx) {
my $d = $list[$idx] - $list[$idx - 1];
if ( $prevd && $prevd != $d ) {
push @result, [$list[$idx]];
$prevd = 0;
}
else {
push @{$result[$#result]}, $list[$idx];
$prevd = $d;
}
}
@result =
map {
if ( @$_ > 2 ) {
my $d = $_->[1] - $_->[0];
[@$_[0, $#$_], ($d>1)?($d):()];
}
else {
@$_;
}
} @result;
use Data::Dumper;
print Dumper(\@result);
|
2^i * 3^j * 5^k なる整数
(Nested
Flatten)
one-linerというかgolfというか... アルゴリズムは他の皆さんと同じです。
1 2 3 | 1==shift@z&&++$n&&printf"%d = 2^%d * 3^%d *%s 5^%d\n",@z
while$n<100&&(@z=(++$i,$i,0,0,'',0))&&
map{$z[0]/=$_,++$z[$_]until$z[0]%$_}2,3,5
|
比較しないソートの作成
(Nested
Flatten)
バケットソートです。ワンライナーで書いてみました。 最大値と個数は無視します。
1 | ($n,$x,$c,@s)=@ARGV;$b[$_-$n]++for@s;$b[$_]&&print(($_+$n.' ')x$b[$_])for 0..$#b
|
起動オプションの解析
(Nested
Flatten)
-d は、必須オプションとして処理しています。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | use strict;
use Getopt::Std;
#ex>cmdopt -o [-q] -d{0|1|2} 文字列 [文字列 ...]
our( $opt_o, $opt_q, $opt_d );
getopts('oqd:');
die "oオプションが指定されていない\n" unless $opt_o;
die "dオプションが指定されていない\n" unless defined $opt_d;
die "dオプションの引数は0-2\n" unless ($opt_d eq '0' || $opt_d eq '1' || $opt_d eq '2');
die "パラメータが指定されていない\n" unless @ARGV;
print "[オプション情報]\n";
print "o(output): ON\n" if $opt_o;
print "q(quote): " . ($opt_q ? "ON" : "OFF") . "\n";
print "d(debug): $opt_d\n";
print "\n[パラメータ情報]\n";
printf("指定数: %d\n", $#ARGV+1);
my $c = 0;
for my $arg (@ARGV){
$c++;
print "$c: $arg\n";
}
|
マルバツゲーム:賢いプレイヤー
(Nested
Flatten)
4つの戦略(どのように石を置くか)を作りました:
1. put_stone_random ... ランダムに置く。
2. ps_prevent_losing ... リーチをかけられてるなら、防ぐ。さもなくば1.の戦略をとる。
3. ps_grasp_chance ...リーチをかけてるなら、そこにおいてゲームに勝つ。さもなくば2.の戦略をとる。
4. ps_smart ...
リーチをかけてるなら、そこにおいてゲームに勝つ。
リーチをかけられてるなら、防ぐ。
さもなくば、可能な限り、ダブルリーチを仕掛けに行く。
ps_smart を書くために、マルバツゲームを手で解きました。
各盤面に対する最善手を %ptn_pos_h に押し込めました。
蛇足:%ptn_pos_h を調整することで、 ps_smart の強さを調整できます。
実行結果: perl marubatsu.pl
***** ps_smart vs put_stone_random *****
game 1..10000
D=>115 o=>9885
***** put_stone_random vs ps_smart *****
game 10001..20000
D=>2373 x=>7627
***** ps_smart vs ps_smart *****
game 20001..20100
D=>100
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 | $board = [map {[map {'-'} 0..2]} 0..2];
sub game {
clear($board);
game_loop(@_);
}
sub game_loop {
my ($player1, $player2) = @_;
my $w;
$player1->{put_stone}($player1->{stone});
if ($w=check($board)) { return $w; }
game_loop($player2,$player1);
}
sub put_stone_random {
my $stone = shift;
while (1) {
my($r,$c) = (int rand @$board, int rand @$board);
if (0<=$r and $r<@$board and
0<=$c and $c<@$board and
$board->[$r][$c] eq '-') {
$board->[$r][$c] = $stone;
last;
}
}
}
sub ps_prevent_losing { # ps :abbrev: put_stone
my $stone = shift;
my($r,$c) = pos_oppreach($board,$stone);
if (defined($r) and defined($c)) {
$board->[$r][$c] = $stone;
} else {
put_stone_random($stone);
}
}
sub ps_grasp_chance {
my $stone = shift;
my($r,$c) = pos_oppreach($board,oppstone($stone));
if (defined($r) and defined($c)) {
$board->[$r][$c] = $stone;
} else {
ps_prevent_losing($stone);
}
}
sub ps_smart {
my $stone = shift;
# ps_grasp_chance
my($r,$c) = pos_oppreach($board,oppstone($stone));
if (defined($r) and defined($c)) {
$board->[$r][$c] = $stone;
return;
}
# ps_prevent_losing
($r,$c) = pos_oppreach($board,$stone);
if (defined($r) and defined($c)) {
ps_prevent_losing($stone);
return;
}
# attack dreach # dreach :abbrev: double reach
($r,$c) = pos_smart($board,$stone);
if (defined($r) and defined($c)) {
$board->[$r][$c] = $stone;
return;
}
put_stone_random($stone);
}
sub pos_oppreach {
my($board,$stone) = @_;
my($r,$c);
($r,$c) = pos_oppreach_row($board,$stone);
if (defined($r) and defined($c)) { return ($r,$c); }
($r,$c) = pos_oppreach_column($board,$stone);
if (defined($r) and defined($c)) { return ($r,$c); }
($r,$c) = pos_oppreach_crossline($board,$stone);
if (defined($r) and defined($c)) { return ($r,$c); }
(undef, undef)
}
sub pos_oppreach_row {
my($board,$stone) = @_;
my @board_strs = join0s($board);
for (0..(@$board-1)) {
my $i = index_oppreach($board_strs[$_], $stone);
if (defined($i)) {
return ($_, $i);
}
}
(undef, undef);
}
sub pos_oppreach_column {
my($board,$stone) = @_;
my @board_strs = ($board->[0][0].$board->[1][0].$board->[2][0],
$board->[0][1].$board->[1][1].$board->[2][1],
$board->[0][2].$board->[1][2].$board->[2][2]);
for (0..(@$board-1)) {
my $i = index_oppreach($board_strs[$_], $stone);
if (defined($i)) {
return ($i, $_);
}
}
(undef, undef);
}
sub pos_oppreach_crossline {
my($board,$stone) = @_;
my @board_strs = get_crosslines($board);
my $i = index_oppreach($board_strs[0], $stone);
if (defined($i)) {
return ($i,$i);
}
$i = index_oppreach($board_strs[1], $stone);
if (defined($i)) {
return (@$board-1-$i,$i);
}
(undef, undef);
}
sub index_oppreach { # test: index_oppreach('o-o', 'x') == 1
my $s = $_[0];
my $o = oppstone($_[1]);
if ($o eq 'o') {
if ($s eq '-oo') { return 0; }
if ($s eq 'o-o') { return 1; }
if ($s eq 'oo-') { return 2; }
} else { # $o eq 'o'
if ($s eq '-xx') { return 0; }
if ($s eq 'x-x') { return 1; }
if ($s eq 'xx-') { return 2; }
}
undef;
}
sub oppstone {
$_[0] eq 'o' ? 'x' : $_[0] eq 'x' ? 'o' : undef;
}
my %ptn_pos_h;
{
my $ptn_pos_href = {
# play first
'--- --- ---' => [0,0],
'ox- --- ---' => [1,1], # [2,0] is also ok : [2,0] [1,0] [2,2]
'ox- -o- --x' => [1,0], # dreach
'o-x --- ---' => [2,0],
'o-x x-- o--' => [2,2], # dreach
'o-- --x ---' => [2,0], # dreach by gc
'o-- --- --x' => [2,0],
'o-- x-- o-x' => [0,2], # dreach ... same as 'o-x x-- o--'
'o-- -x- ---' => [2,2],
'o-x -x- --o' => [2,0], # dreach
# play second / first ps pos == (0 0)
'o-- --- ---' => [1,1],
'o-- -x- --o' => [2,1], # draw by gc
'o-- -x- -o-' => [2,2], # dreach by gc 1/5 , draw by gc 4/5
# play second / first ps pos == (1 1)
'--- -o- ---' => [0,0],
'x-- -o- --o' => [0,2], # draw by gc
# play second / first ps pos == (0 1)
'-o- --- ---' => [0,0],
'xoo --- ---' => [2,0],
'xoo o-- x--' => [2,2], # dreach
'xo- --o ---' => [2,0], # dreach by gc
'xo- --- o--' => [1,1], # draw by gc
'xo- o-- ---' => [2,1],
'xoo o-- -x-' => [2,2], # dreach
'xo- o-- ox-' => [0,2], # draw by gc
'xo- o-- -xo' => [0,2], # draw by gc
'xo- --- --o' => [1,1], # dreach by gc 1/5 , draw by gc 4/5
};
%ptn_pos_h = %$ptn_pos_href;
}
sub pos_smart { # assume: play first => 'o', play second => 'x', marubatsuptn
my($board,$stone) = @_;
for my $m (0..1) { # means: nflip
for my $n (0..3) { # means: nrot
my $ptn = match_board(brott($n,bflipt($m,$board)));
if (defined $ptn) {
#print "$ptn => @{$ptn_pos_h{$ptn}} : $m $n : debugwrite";
return to_a(pflipt($m,prott(-$n,$ptn_pos_h{$ptn})));
}
}
}
(undef, undef);
}
sub brott {
my($n, $board) = @_;
dotimes($n % 4, $board, \&brot);
}
sub bflipt {
my($n, $board) = @_;
dotimes($n % 2, $board, \&bflip);
}
sub pflipt {
my($n, $pos) = @_;
dotimes($n % 2, $pos, \&pflip);
}
sub prott {
my($n, $pos) = @_;
dotimes($n % 4, $pos, \&prot);
}
sub dotimes {
my($n, $obj, $coderef) = @_;
$n==0 ? $obj : dotimes($n-1, $coderef->($obj), $coderef);
}
sub brot {
trans(bflip($_[0]));
}
sub bflip {
[map {[reverse @$_];} @{$_[0]}];
}
sub pflip {
my @b = @{$_[0]};
$b[1] = 2 - $b[1]; # pos flip
\@b;
}
sub prot {
my @b = @{$_[0]};
$b[0]-=1; $b[1]-=1;
my @c = (-$b[1], $b[0]); # pos rot ... 90 degree
$c[0]+=1; $c[1]+=1;
\@c;
}
sub match_board {
my $board_str = join(' ', join0s(shift));
my @mp = grep { $board_str eq $_; } keys %ptn_pos_h;
(scalar @mp) ? $mp[0] : undef;
}
sub to_a {
@{$_[0]};
}
sub check {
my @b = @{$_[0]};
my $w;
# check rows
for my $r (0..2) {
my $l = $b[$r]->[0]; # abbrev: left of board
if ($l ne'-' and $l eq$b[$r]->[1] and $l eq$b[$r]->[2]) { return $l; }
}
# check columns
for my $c (0..2) {
my $t = $b[0]->[$c]; # abbrev: top of board
if ($t ne'-' and $t eq$b[1]->[$c] and $t eq$b[2]->[$c]) { return $t; }
}
# check crosslines
my $p = $b[0]->[0]; # abbrev: pos
if ($p ne'-' and $p eq$b[1]->[1] and $p eq$b[2]->[2]) { return $p; }
$p = $b[2]->[0];
if ($p ne'-' and $p eq$b[1]->[1] and $p eq$b[0]->[2]) { return $p; }
# check draw
if (filledp(\@b)) { return 'D'; } # means: draw
undef;
}
sub join0s {
my @b = @{$_[0]};
my @a;
$a[0] = join '', @{$b[0]};
$a[1] = join '', @{$b[1]};
$a[2] = join '', @{$b[2]};
@a;
# map {join '', @$_} @{$_[0]};
}
sub trans {
my $m = shift;
my $n = [];
for my $r (0..2) {
for my $c (0..2) {
$n->[$c][$r] = $m->[$r][$c];
}
}
$n;
}
sub get_crosslines {
my $b = shift;
join0s [[map {$b->[ $_][$_]} 0..(@$b-1)],
[map {$b->[@$b-1-$_][$_]} 0..(@$b-1)]];
}
sub filledp {
my $b = shift;
for my $r (0..(@$b-1)) {
for my $c (0..(@{$b->[$r]}-1)) {
if ($b->[$r][$c] eq '-') { return 0; }
}
}
1;
}
# utilities
sub clear {
my $b = shift;
for my $r (0..(@$b-1)) {
for my $c (0..(@{$b->[$r]}-1)) {
$b->[$r][$c] = '-';
}
}
}
################### run game ###################
$gc = 0; # abbrev: game count
sub game_times {
my($player1,$player2,$ngame) = @_;
my %wc;
print "***** $player1 vs $player2 *****\n";
print "game ", $gc+1, "..", $gc+$ngame, "\n";
$gc += $ngame;
for (1..$ngame) {
my $w = game({put_stone=>\&$player1, stone=>'o'},
{put_stone=>\&$player2, stone=>'x'});
$wc{$w}++;
}
while (my($k,$v) = each(%wc)) {
print "$k=>$v ";
}
print "\n";
}
$ngame = 10000;
game_times('ps_smart', 'put_stone_random', $ngame);
game_times('put_stone_random', 'ps_smart', $ngame);
game_times('ps_smart', 'ps_smart', 100);
|
LL Golf Hole 9 - トラックバックを打つ
(Nested
Flatten)
お題がGolf向けじゃないとか.. 後、さすがに一行では表示がえらいことになるので、適当に改行
1 2 3 4 5 | use LWP::UserAgent;
print LWP::UserAgent->new->post(
'http://ll.jus.or.jp/2008/blog/archives/38/trackback',
{qw{blog_name LLGolfHole9 title llfuture url http://ja.doukaku.org/207
excerpt LLGolf最終ホールを打ってみた}})->content
|
文字列型日時ののN秒後時間取得
(Nested
Flatten)
モジュールなしで書いた
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | #! /usr/bin/perl
use strict;
use warnings;
my $date_string = 20080827235925;
my $add_seconds = 40;
print DateEx($date_string,$add_seconds);
sub DateEx{
my ($date_string, $add_seconds) = @_;
return 'Error!' unless $date_string =~ /^\d{14}$/;
return 'Error!' unless $add_seconds =~ /^-?\d+$/;
my ($year,$month,$day,$hour,$minutes,$seconds)
= $date_string =~ /^(\d{1,4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/;
my @result = add_seconds($year,$month,$day,$hour,$minutes,$seconds,$add_seconds);
return sprintf("%04d%02d%02d%02d%02d%02d",@result);
}
sub add_seconds{
my ($year,$month,$day,$hour,$minutes,$seconds,$add_seconds) = @_;
#時間、秒を先に出す
my ($tmp_day,$result_hour,$result_minutes,$result_seconds)
= seconds_to_day($add_seconds + day_to_seconds($day-1,$hour,$minutes,$seconds));
#日付を計算
my ($result_year, $result_month, $result_day)
= date_add($year,$month,$tmp_day);
return ($result_year,$result_month,$result_day,$result_hour,$result_minutes,$result_seconds);
}
sub day_to_seconds{#何日、何時間、何分の形式を総秒数に変換
my ($day,$hour,$minutes,$seconds) = @_;
my $SECONDS_PER_MINUTES = 60;
my $SECONDS_PER_HOUR = $SECONDS_PER_MINUTES * 60;
my $SECONDS_PER_DAY = $SECONDS_PER_HOUR * 24;
my $total_second = $day * $SECONDS_PER_DAY
+ $hour * $SECONDS_PER_HOUR
+ $minutes * $SECONDS_PER_MINUTES
+ $seconds
;
return $total_second;
}
sub seconds_to_day{#秒数を 何日、何時間、何分の形式に変換
my ($total_seconds) = @_;
my $SECONDS_PER_MINUTES = 60;
my $SECONDS_PER_HOUR = $SECONDS_PER_MINUTES * 60;
my $SECONDS_PER_DAY = $SECONDS_PER_HOUR * 24;
my ($day,$hour,$minutes,$seconds) = (0,0,0,0);
if($total_seconds > 0){
$day = int($total_seconds / $SECONDS_PER_DAY) + 1;
$hour = int($total_seconds / $SECONDS_PER_HOUR) % 24;
$minutes = int($total_seconds / $SECONDS_PER_MINUTES) % 60;
$seconds = $total_seconds % 60;
}
elsif($total_seconds < 0){
$day = (int(($total_seconds * (-1))/$SECONDS_PER_DAY) + 1) * (-1);
$total_seconds += $day * $SECONDS_PER_DAY * (-1);
$hour = int($total_seconds / $SECONDS_PER_HOUR) % 24;
$minutes = int($total_seconds / $SECONDS_PER_MINUTES) % 60;
$seconds = $total_seconds % 60;
}
return ($day,$hour,$minutes,$seconds);
}
sub date_add{#2008年8月33日は2008年9月2日のような考え方
my ($year,$month,$day) = @_;
#400年以上のスパンがある場合
while(abs($day) > (my $DAYS_IN_400YEARS = 365*400+97)){
if($day > 0){
$day -= $DAYS_IN_400YEARS;
$year += 400;
}
else{
$day += $DAYS_IN_400YEARS;
$year -= 400;
}
}
#1年以上のスパンがある場合
while(abs($day) > 366){
if($day > 0){
if($month <= 2){
while($day > 366){
_uru_or_not($year) ? $day -= 366 : $day -= 365;
$year++;
}
}
else{
while($day > 366){
_uru_or_not($year+1) ? $day -= 366 : $day -= 365;
$year++;
}
}
}
else{
if($month <= 2){
while($day < -366){
_uru_or_not($year-1) ? $day += 366 : $day += 365;
$year--
}
}
else{
while($day < -366){
_uru_or_not($year) ? $day += 366 : $day += 365;
$year--
}
}
}
}
#一月づつ、足すもしくはさかのぼる
while(!(($day > 0) && (_get_days_of_month($year,$month) >= $day))){
if($day > 0){
$day -= _get_days_of_month($year,$month);
$month++;
if($month == 13){
$year++;
$month = 1;
}
}
else{
$month--;
if($month == 0){
$year--;
$month = 12;
}
$day += (_get_days_of_month($year,$month) + 1);
}
}
return ($year,$month,$day);
}
sub _uru_or_not{#閏年か否かの判定
my ($year) = @_;
return 1 if($year % 400 == 0);
return 0 if($year % 100 == 0);
return 1 if($year % 4 == 0);
return 0;
}
sub _get_days_of_month{#年と月を与えるとその日数を返す
my ($year,$month) = @_;
my @days_of_months = qw{0 31 28 31 30 31 30 31 31 30 31 30 31};
if(($month == 2) && (_uru_or_not($year))){
return 29;
}
return $days_of_months[$month];
}
|
Perlにまでパーサっがあったのですね。。。 僕が妥協した時はPOSIXを使ったべた書きでした。 # ほとんどCとかわりません(笑


turugina
#7766()
[
Perl
]
Rating0/0=0.00
Rating0/0=0.00-0+