Language detail: Perl
Coverage: 90.36%
|
number of '+' ratings |
contribution for coverage |
Unsolved challenges
- 年賀はがきの当せん番号 (Nested Flatten)
- 箱詰めパズルの判定 (Nested Flatten)
- 関数やメソッドのソースの平均行数 (Nested Flatten)
- コレクションの実装 (Nested Flatten)
- 化学反応式の完成 (Nested Flatten)
codes
ピラミッドを作る
(Nested
Flatten)
1 2 3 4 5 6 7 8 9 10 11 | use strict;
use warnings;
sub piramid {
my $n = shift;
for (my $i = 1; $i <= $n; $i++) {
printf("%s%s\n", " " x ($n - $i), "*" x ($i * 2 -1));
}
}
&piramid($ARGV[0])
|
居眠り床屋問題
(Nested
Flatten)
Coroを使って疑似並列処理しました。 ついでに実行時間[sec]も表示しています。
[Coro=HASH(0x81d3a0)] [0.000] 床屋、眠る
[Coro=HASH(0x810ad0)] [0.199] 来店 1
[Coro=HASH(0x81d3a0)] [0.199] 床屋、目覚める
[Coro=HASH(0x81d3a0)] [0.199] 散髪開始 1
[Coro=HASH(0x810ad0)] [0.310] 来店 2
[Coro=HASH(0x810ad0)] [0.466] 来店 3
[Coro=HASH(0x81d3a0)] [0.504] 散髪完了 1
[Coro=HASH(0x81d3a0)] [0.505] 散髪開始 2
[Coro=HASH(0x810ad0)] [0.574] 来店 4
[Coro=HASH(0x810ad0)] [0.765] 来店 5
[Coro=HASH(0x812ce0)] [0.765] 満席で立ち去る 5
[Coro=HASH(0x81d3a0)] [0.812] 散髪完了 2
[Coro=HASH(0x81d3a0)] [0.812] 散髪開始 3
[Coro=HASH(0x810ad0)] [0.930] 来店 6
[Coro=HASH(0x810ad0)] [0.969] 来店 7
[Coro=HASH(0x812bd0)] [0.969] 満席で立ち去る 7
[Coro=HASH(0x810ad0)] [1.101] 来店 8
[Coro=HASH(0x812c90)] [1.102] 満席で立ち去る 8
[Coro=HASH(0x81d3a0)] [1.186] 散髪完了 3
[Coro=HASH(0x81d3a0)] [1.186] 散髪開始 4
[Coro=HASH(0x81d3a0)] [1.374] 散髪完了 4
[Coro=HASH(0x81d3a0)] [1.374] 散髪開始 6
[Coro=HASH(0x81d3a0)] [1.618] 散髪完了 6
[Coro=HASH(0x81d3a0)] [1.618] 床屋、眠る
[Coro=HASH(0x810ad0)] [2.302] 来店 9
[Coro=HASH(0x81d3a0)] [2.302] 床屋、目覚める
[Coro=HASH(0x81d3a0)] [2.302] 散髪開始 9
[Coro=HASH(0x810ad0)] [2.312] 来店 10
[Coro=HASH(0x810ad0)] [2.475] 来店 11
[Coro=HASH(0x810ad0)] [2.494] 来店 12
[Coro=HASH(0x812df0)] [2.494] 満席で立ち去る 12
[Coro=HASH(0x810ad0)] [2.545] 来店 13
[Coro=HASH(0x812be0)] [2.545] 満席で立ち去る 13
[Coro=HASH(0x81d3a0)] [2.612] 散髪完了 9
[Coro=HASH(0x81d3a0)] [2.612] 散髪開始 10
[Coro=HASH(0x810ad0)] [2.687] 来店 14
[Coro=HASH(0x810ad0)] [2.862] 来店 15
[Coro=HASH(0x812e00)] [2.863] 満席で立ち去る 15
[Coro=HASH(0x81d3a0)] [2.878] 散髪完了 10
[Coro=HASH(0x81d3a0)] [2.878] 散髪開始 11
[Coro=HASH(0x81d3a0)] [3.034] 散髪完了 11
[Coro=HASH(0x81d3a0)] [3.034] 散髪開始 14
[Coro=HASH(0x810ad0)] [3.046] 来店 16
[Coro=HASH(0x81d3a0)] [3.248] 散髪完了 14
[Coro=HASH(0x81d3a0)] [3.248] 散髪開始 16
[Coro=HASH(0x81d3a0)] [3.547] 散髪完了 16
[Coro=HASH(0x81d3a0)] [3.547] 床屋、眠る
※16人のうち10人を散髪
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 | #!/usr/bin/env perl
use strict;
use warnings;
use feature qw/say/;
use utf8;
use Coro;
use Coro::Semaphore;
use Time::HiRes qw/time/;
sub rand_int($$) {
my ($min, $max) = @_;
$min + int rand ($max - $min + 1);
}
{
my $start_time;
sub init_time() { $start_time = time }
sub elapse() { sprintf '%5.3f', time - $start_time }
}
binmode STDOUT, ':utf8';
my $free_seats = Coro::Semaphore->new(3);
my $barber_awaken = 1;
my $all_customers_done = 0;
my $num_cut = 0;
my @customer_queue;
init_time;
my $barber = async {
while (1) {
if (@customer_queue) {
unless ($barber_awaken) {
$barber_awaken = 1;
say "[$Coro::current] [@{[elapse]}] 床屋、目覚める";
}
my ($customer, $cutting_done) = @{ shift @customer_queue };
my $wait_sec0 = time;
my $wait_sec = rand_int(100, 400) / 1000;
say "[$Coro::current] [@{[elapse]}] 散髪開始 $customer";
cede until time - $wait_sec0 > $wait_sec;
$cutting_done->();
$num_cut++;
say "[$Coro::current] [@{[elapse]}] 散髪完了 $customer";
} elsif ($barber_awaken) {
$barber_awaken = 0;
say "[$Coro::current] [@{[elapse]}] 床屋、眠る";
} elsif($all_customers_done) {
last;
}
cede;
}
};
my @customers;
for my $i (1 .. 16) {
my $wait_sec0 = time;
my $wait_sec = ($i == 9 ? 1200 : rand_int(0, 200)) / 1000;
cede until time - $wait_sec0 > $wait_sec;
say "[$Coro::current] [@{[elapse]}] 来店 $i";
push @customers, async {
unless ($free_seats->try) {
say "[$Coro::current] [@{[elapse]}] 満席で立ち去る $i";
terminate;
}
my $cutting_done = 0;
push @customer_queue, [$i,
sub {
$cutting_done = 1;
$free_seats->up;
}];
cede until $cutting_done;
};
cede;
}
$_->join for @customers;
$all_customers_done = 1;
$barber->join;
say "※16人のうち${num_cut}人を散髪";
|
UTF-16をUTF-8に変換
(Nested
Flatten)
変換はEncodeまかせです。
1 2 3 4 5 6 7 8 9 10 | use strict;
use warnings;
use Encode;
$,=' ';
print map{sprintf'%08b',$_}
unpack('C*',
encode('utf8',
decode('utf16be',
pack('C*',
map hex,@ARGV))));
|
Twitterへの投稿
(Nested
Flatten)
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | use strict;
use warnings;
use Config::Pit;
use Net::Twitter;
use utf8;
my $c = pit_get("twitter.com",
require => {
username => "your twitter id",
password => "your twitter password",
},
) or die "failed to get auth info";
my $t = Net::Twitter->new( %$c );
$t->update('http://ja.doukaku.org/278/ 用のテスト');
|
/*コメント*/を取り除く
(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 | use strict;
use warnings;
sub main()
{
my @str = (
'AAA',
'AAA/*BBB*/',
'AAA/*BBB',
'AAA/*BBB*/CCC',
'AAA/*BBB/*CCC*/DDD*/EEE',
'AAA/a//*BB*B**/CCC',
);
for my $s (@str) {
print("Original[$s]: ", "((", remove_comment($s), "))", "\n");
}
}
sub remove_comment($)
{
my $str = shift;
my $regex = qr#/\*.*?\*/|/\*.*#;
$str =~ s#$regex##;
return $str;
}
main();
|
指定されたフォルダ以下のゴミ掃除
(Nested
Flatten)
File::Find::Rule で削除対象ファイルをリストとして取得。あとでまとめて削除している。 コードが長いのは消す確認を2度しているのと、Optionをお約束で入れてみたから。
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 | #! /opt/local/bin/perl
use strict;
use warnings;
use Getopt::Long;
use File::Find::Rule;
# Remove all files matching $TARGET_REGEX
my $TARGET_REGEX = qr/~$/;
my %options = (
"debug" => undef, # debug mode
);
GetOptions (
"debug" => \$options{debug},
) || die("failed GetOptions");
sub main()
{
my @dir = ("."); # default
@dir = @ARGV if @ARGV;
firstConfirm(\@dir);
rmR(\@dir);
}
sub firstConfirm(\@)
{
my $dir = shift;
for my $d (@$dir) {
print $d, "\n";
die("Usage: $0 dir1 dir2 ") if ! -d $d;
}
print STDERR qq/[WARNING] removing files ending with "~" under "@$dir" directory.\n/;
my $confirm_str = "I want to continue";
print STDERR qq/Execute? [Type "$confirm_str"]: /;
chomp(my $line = <STDIN>);
if ($line !~ $confirm_str) {
print STDERR "bye\n";
exit(0);
}
}
sub rmR(\@)
{
my $dir = shift;
print STDERR "[DEBUG] removing under @$dir\n" if defined $options{debug};
my @files_to_remove = File::Find::Rule->file()
->name($TARGET_REGEX)
->in(@$dir);
my $f_count = @files_to_remove;
if ( defined $f_count && ($f_count == 0) ) {
print STDERR "\nNo file[s] to remove found.\n";
exit(0);
}
doRm(\@files_to_remove) if finalConfirm(\@files_to_remove);
}
sub finalConfirm(\@)
{
my $files_to_remove_ref = shift;
my $result ;
print "unlinking:\n";
print map "\t\t$_\n", @$files_to_remove_ref;
print "continue?[y/n]: ";
my $ans = <STDIN>;
$result = 1 if $ans =~ m/y(es){0,1}/i;
return $result;
}
sub doRm(\@)
{
my $dir_ref = shift;
unlink @{$dir_ref};
}
main();
|
急勾配の判定
(Nested
Flatten)
#8973のボトルネックはreverseした値を配列にコピーしているところですね。
for(each)に直接渡すと最適化されるのでpopよりずっと速いです。以下ベンチマーク。
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 | use Benchmark qw/cmpthese/;
my @steep = map { 2 ** $_ } reverse 0 .. 49;
cmpthese(100_000,
{ pop => sub { is_steep0(@steep) },
rev_cp => sub { is_steep1(@steep) },
rev => sub { is_steep2(@steep) },
nk_pop => sub { is_steep3(@steep) },
sk_rev => sub { is_steep4(@steep) } });
sub is_steep0 {
my $total = 0;
while (my $i = pop) {
return unless $total < $i;
$total += $i;
}
return 1;
}
sub is_steep1 {
my $total = 0;
my @rev = reverse @_;
for my $i (@rev) {
return unless $i > $total;
$total += $i;
}
return 1;
}
sub is_steep2 {
my $total = 0;
for my $i (reverse @_) {
return unless $i > $total;
$total += $i;
}
return 1;
}
# http://ja.doukaku.org/comment/9251/
sub is_steep3 {
my ($x,$q) = 0;
$x < ($q = pop||return 1) ? $x += $q : return 0 while 1;
}
sub is_steep4 {
my $total = 0;
$total < $_ ? $total += $_ : return 0 for reverse @_;
return 1;
}
|
いちばん長いしりとり
(Nested
Flatten)
map万歳! 最悪計算量はO(N!)のはず。 お題に挙げられている単語リストだと110語あたりが限界です。 $ time perl doukaku227.pl fam55_40.txt 100 セイギハ -> ハゲヤマ -> マヤカシ -> ショウワル -> ルイベツ -> ツジツマ -> マタシタ -> タチノミ -> ミズヒキ -> キャクアシ -> シャクナゲ -> ゲレツサ -> サンバシ -> シールド -> ドウナガ -> ガイユウ -> ウワバリ -> リンセツ -> ツユザム -> ムスビメ -> メイフク real 0m0.585s user 0m0.561s sys 0m0.012s
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 | #!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use List::Util qw/reduce/;
my @katakanas = split //, 'アイウエオカキクケコガキグゲゴサシスセソ'
. 'ザジズゼゾタチツテトダヂヅデドナニヌネノ'
. 'ハヒフヘホバビブベボパピプペポマミムメモ'
. 'ヤユオワヲン';
sub head_and_tail($) {
my $word = shift;
$word =~ tr/ァィゥェォッャュョヮ/アイウエオツヤユヨワ/;
$word =~ s/ー$//;
(substr($word, 0, 1), substr($word, -1, 1));
}
sub longest_chain(\%;$);
sub longest_chain(\%;$) {
no warnings qw/recursion/;
my ($dict, $word) = @_;
my @words = defined $word
? ($word)
: map { map { $_->[0] } values %$_ } values %$dict;
reduce {
@$a > @$b ? $a : $b;
} ([],
map {
my $word = $_;
my (undef, $next_head) = head_and_tail $word;
map {
my $available_words = $dict->{$next_head}{$_};
my $next_word = pop @$available_words;
my $chain = longest_chain(%$dict, $next_word);
push @$available_words, $next_word;
unshift @$chain, $word;
$chain;
} grep { @{ $dict->{$next_head}{$_} } } keys %{ $dict->{$next_head} };
} @words);
}
binmode STDOUT, ':utf8';
open my $words_file, '<:encoding(shiftjis)', shift or die $!;
my @words = (map { chomp; split /\s+/ } <$words_file>);
$#words = shift() - 1 if @ARGV;
my %dict;
for my $word (@words) {
my ($head, $tail) = head_and_tail $word;
$dict{$head}{$tail} = [] unless exists $dict{$head}{$tail};
push @{ $dict{$head}{$tail} }, $word;
}
local ($,, $\) = (' -> ', "\n");
print @{ longest_chain(%dict) };
|
とりあえず。検証もしてないのですが、お題の単語リストの先頭「アイアイ」から始めて350個繋がりました。
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 | use strict;
use warnings;
use utf8;
use Encode;
my $input_enc = shift || 'utf-8';
my $output_enc = shift || 'cp932';
my $words = readwords();
my $table = maketable($words);
my $total = @$words;
my $count = 0;
#my $next = $words->[int rand $total];
my $next = $words->[0];
erase($next, $table);
print encode($output_enc, "begin from [$next]\n");
while ( 1 ) {
++$count;
last if is_stop($next);
my $prev = $next;
$next = draw_next($prev, $table);
last if !defined $next;
print encode($output_enc, "next -> [$next]\n");
}
print encode($output_enc, "END ($count/$total)\n");
sub readwords
{
[ map { tr/ア-ン/あ-ん/; $_ }
map { decode($input_enc, $_) }
map { chomp; split /\s+/ } <STDIN> ];
}
sub maketable
{
my $words = shift;
my %table;
for my $w ( @$words ) {
my $first = substr $w, 0, 1;
$table{$first} = [0,0,[]] if !exists $table{$first};
++$table{$first}[0];
if ( is_stop($w) ) {
++$table{$first}[1];
}
push @{$table{$first}[2]}, $w;
}
\%table;
}
sub erase
{
my ($word, $table) = @_;
my $first = substr $word, 0, 1;
--$table->{$first}[0];
if ( is_stop($word) ) {
--$table->{$first}[1];
}
@{$table->{$first}[2]} = grep { $_ ne $word } @{$table->{$first}[2]};
}
sub draw_next
{
my ($word, $table) = @_;
my $next = get_candidate($word, $table)->[0];
erase($next, $table) if defined $next;
$next;
}
sub is_stop
{
my $word = shift;
(length($word)>1 ? substr $word, -1, 1 : $word) eq 'ん';
}
sub get_candidate
{
my ($word, $table) = @_;
my $last = substr $word, -1, 1;
my $candidate = [undef, -1];
for my $next ( @{$table->{$last}[2]} ) {
my $next_last = substr $next, -1, 1;
my $point = exists $table->{$next_last}
? $table->{$next_last}[0] - $table->{$next_last}[1]
: 0;
if ( $point > $candidate->[1] ) {
$candidate = [$next, $point];
}
}
$candidate;
}
|
ラングトンのアリの描画
(Nested
Flatten)
Perl/Tk でごりごり書いてみました。
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 | use strict;
use warnings;
use Tk;
use Tk::MsgBox;
use utf8;
my $w = shift || 100;
my $h = shift || $w;
my $pxsize = 4;
my $init_pattern_subs = create_pattern_subs();
my $pattern = shift;
my $pattarn_sub = $pattern && exists $init_pattern_subs->{$pattern}
? $init_pattern_subs->{$pattern}
: sub { 0 };
my $mw = Tk::MainWindow->new(-title => 'ラングトンの蟻');
my $control_frame = $mw->Frame;
$control_frame->pack(
-side => 'bottom',
-anchor => 's',
-fill => 'x',
);
my $drawing_frame = $mw->Frame;
$drawing_frame->pack(
-side => 'top',
-anchor => 'n',
-fill => 'both',
);
my $canvas = $drawing_frame->Canvas(
-width => $w * $pxsize, -height => $h * $pxsize,
-background => 'white',
);
my @field;
for my $x ( 0 .. $w-1 ) {
for my $y ( 0 .. $h-1 ) {
$field[$x][$y] = $canvas->createRectangle(
(map{$_ * $pxsize} $x,$y,$x+1,$y+1),
-fill => 'white'
);
}
}
$canvas->pack(-fill => 'both');
my $start_button = $control_frame->Button(
-text => 'START',
-command => \&start_proc,
-state => 'normal',
);
$start_button->pack(-anchor => 'w', -side => 'left');
my $stop_button = $control_frame->Button(
-text => 'STOP',
-command => \&stop_proc,
-state => 'disabled',
);
$stop_button->pack(-anchor => 'w', -side => 'left', -padx => 20);
my $stat = step_label(0,0,0);
my $stat_label = $control_frame->Label(
-textvariable => \$stat
);
$stat_label->pack(-anchor => 'w', -side => 'left', -padx => 30);
Tk->MainLoop;
sub create_pattern_subs
{
+{
ichimatsu => sub { (($_[0]/2) ^ ($_[1]/2)) & 0x1; },
lines => sub { ($_[0]/12) & ($_[1]/2) & 0x1; },
random => sub { !int rand 3 },
};
}
sub step_label
{
sprintf '%#8d steps (%#3d, %#3d)', @_;
}
{
my ($count,$x,$y,$d,$timer);
sub start_proc
{
$stop_button->configure(-state => 'normal');
$start_button->configure(-state => 'disabled');
$count = 0;
$x = int(rand($w/2) + $w/4);
$y = int(rand($h/2) + $h/4);
$d = int(rand(4));
for my $x_ ( 0 .. $w-1 ) {
for my $y_ ( 0 .. $h-1 ) {
$canvas->itemconfigure($field[$x_][$y_],
-fill => $pattarn_sub->($x_,$y_) ? 'black' : 'white');
}
}
$timer = $mw->repeat(10, \&next_step);
}
sub stop_proc
{
$stop_button->configure(-state => 'disabled');
$start_button->configure(-state => 'normal');
$mw->afterCancel($timer);
}
sub next_step
{
my $bit = $canvas->itemcget($field[$x][$y], '-fill') ne 'white';
$canvas->itemconfigure($field[$x][$y], -fill => ($bit ? 'white' : 'black'));
$d = ($bit ? ++$d : --$d) % 4;
if ( $d == 0 ) { --$x; }
elsif ( $d == 1 ) { ++$y; }
elsif ( $d == 2 ) { ++$x; }
elsif ( $d == 3 ) { --$y; }
if ( $x < 0 || $x >= $w || $y < 0 || $y >= $h ) {
stop_proc;
my $d = $mw->MsgBox(-title => 'END', -message => 'しゅーりょー', -type => 'ok');
$d->Show;
return;
}
$stat = step_label( ++$count, $x, $y);
}
}
|
バイナリクロック
(Nested
Flatten)
少し短くかつPerl 5.8.xでも動くようにしました。-CIOがポイント。
Dan the Perl Monger
1 | perl -CIO -Mutf8 -le 'print for map { $_ = sprintf "%06b", $_; tr/01/□■/; $_ } (localtime)[2,1];'
|
一行野郎。本体73bytes、全部で114bytes。 マルチバイトでなければ-Mスイッチはなくていいです。
1 | perl -Mutf8 -Mopen=:utf8 -Mopen=:std -E'say for map { $_ = sprintf "%06b", $_; tr/01/□■/; $_ } (localtime)[2, 1];'
|
年月日時分秒 まで表示してみました。
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 | use strict;
use warnings;
# Binary clock
$\="\n";
$,=":";
clear_screen();
while ( 1 )
{
my ($sec,$min,$hour,$day,$month,$year)=localtime;
++$month;
$year+=1900;
print bin_($year,'年', 12), sprintf('%4d',$year);
print bin_($month,'月', 5), sprintf('%4d',$month);
print bin_($day,'日', 6) , sprintf('%4d',$day);
print bin_($hour,'時', 6) , sprintf('%4d',$hour);
print bin_($min,'分', 7) , sprintf('%4d',$min);
print bin_($sec,'秒', 7) , sprintf('%4d',$sec);
sleep 1;
clear_screen();
}
sub bin_
{
my ($n,$s,$m) = @_;
'_'x(12-$m) . join '', map { ((1 <<($_-1)) & $n) ? $s : '□' } reverse 1 .. $m;
}
sub clear_screen
{
if ( $^O =~ /Win32/ ) {
system('cls');
}
else {
if (system('clear') != 0) {
print "\x1b[2J";
}
}
}
|
急勾配の判定
(Nested
Flatten)
再帰的に書いてみました。
計算量(という表現でいいかは別として、)は一律に要素数と一致するはず。たぶん。
Tabが一律4半角スペースなのでインデントがおかしいですけどそこはスルーでお願いします。
計算量(という表現でいいかは別として、)は一律に要素数と一致するはず。たぶん。
Tabが一律4半角スペースなのでインデントがおかしいですけどそこはスルーでお願いします。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | #!/usr/local/bin/perl
use strict;
sub isSteep{
my $x = shift||return 1,0;
my @y = isSteep(@_);
return $y[0]&&$x>$y[1]?1:0,$y[1]+$x;
}
my @a1 = (\@{[100, 30, 10, 4, 1]},
\@{[10, 30, 100]},
\@{[10, 4, 2, 1]},
\@{[10, 5, 4, 2]});
print join(', ',@{$_}),' is',((isSteep(@{$_}))[0]?'':'n\'t'),' a steep array.',$/ for@a1;
|
後ろから見ていくことで、効率的になっていますね。 pop使えば、reverseする手間も省けていいんじゃないかなーと思います。
1 2 3 4 | sub isSteep2{
my($x,$q) = 0;
$x < ($q = pop||return 1) ? $x += $q : return 0 while 1;
}
|
Hello, world!その2
(Nested
Flatten)
x演算子さまさま。
1 2 | $,="%c"x23;
eval sprintf($,, 112, 114, 105, 110, 116, 34, 72, 101, 108, 108, 111, 44, 32, 119, 111, 114, 108, 100, 33, 92, 110, 34, 59);
|
ピラミッドを作る
(Nested
Flatten)
ゴルフ場と勘違いしてるのか、ワンライナーしてるやつはなんなの。
1 2 3 4 5 6 7 8 9 10 11 12 | #!/usr/local/bin/perl
use strict;
sub pyramid($$){
my @q = @_;
return $q[0]--?$"x$q[0].'*'x(2*++$q[1]-1).$/.pyramid(@q):'';
}
while(<>){
last if 'q' eq lc substr$_,0,1;
print pyramid int$_, 0;
}
|
メソッド数の多い組み込みクラスを列挙
(Nested
Flatten)
next >>
何もuseしない場合のpackageとそこに定義されてるsubをSTASHから拾ってきて数えてます。
手元の環境(v5.10.0 built for MSWin32-x86-multi-thread) では
main::Win32 --- 21 main::version --- 16 Tie::Hash::NamedCapture --- 9 main::mro --- 9 main::utf8 --- 8 main::Internals --- 6 main::re --- 4 main::UNIVERSAL --- 4 PerlIO::Layer --- 2 main::DynaLoader --- 1
という結果になりました
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 | my %cnt;
my $top = '*main::';
count_subs($top,\%cnt);
--$cnt{$top}; # sub count_subs の分を差し引く
my $i=0;
$\="\n";
print for map { "@{[substr($_->[0],1,-2)]} --- $_->[1]" }
grep { ++$i <= 10 }
sort {$b->[1] <=> $a->[1]}
map { [$_, $cnt{$_}] } keys %cnt;
my %counted;
sub count_subs
{
my ($mod, $cnt) = @_;
return if exists $cnt->{$mod};
$cnt->{$mod} = 0;
return if !defined %{$mod};
while (my ($k,$v) = each %{$mod}) {
if ( substr($k, -2) eq '::' ) {
count_subs($v, \%cnt);
}
elsif (defined &{$v} && !exists $counted{$v}) {
++$cnt->{$mod};
$counted{$v}=undef;
}
}
}
|





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