Latest comments for language 'Perl' on doukaku.org

匿名's comment on 漢数字で九九の表

#!/usr/bin/perl
use strict;
use warnings;

my @kansuji = qw/〇 一 二 三 四 五 六 七 八 九/;

for my $i (@kansuji){
    next unless get_int($i);
    for my $j(@kansuji){
        next unless get_int($j);
        my $product = "";
        $product .= $kansuji[$_] for(split(//,get_int($i)*get_int($j)));
        until(length($product) == length("　　　")){
            $product = "　".$product;
        }
        print $product;
    }
    print "\n";
}
sub get_int{
    my $kanji = shift;
    my $i;
    for(@kansuji){
        last if($kanji eq $_);
        $i++;
    }
    return $i;
}

[ Perl ] [ download code ] ]

Songmu's comment on 漢数字で九九の表

漢数字で九九の表 (Nested Flatten)

#!/usr/bin/perl
use strict;
use warnings;

my @kansuji = qw/〇 一 二 三 四 五 六 七 八 九/;

for my $i (@kansuji){
    next unless get_int($i);
    for my $j(@kansuji){
        next unless get_int($j);
        my $product = "";
        $product .= $kansuji[$_] for(split(//,get_int($i)*get_int($j)));
        until(length($product) == length("　　　")){
            $product = "　".$product;
        }
        print $product;
    }
    print "\n";
}
sub get_int{
    my $kanji = shift;
    my $i;
    for(@kansuji){
        last if($kanji eq $_);
        $i++;
    }
    return $i;
}

[ Perl ] [ download code ] ]

turugina's comment on 疑似並行処理

疑似並行処理 (Nested Flatten)

みんな普通に並行処理書いてるような気がするけど、
お題の「擬似」はどこに行ったんだろうと
思わなくもなく。

というわけで、Perl/Tkで擬似並行処理

use strict;
use warnings;

use Tk;

my $lblvar='';
my $num = 1;
my $al = 'A';

# ウィンドウとラベル
# ラベルに文字が追加されていく
my $mw = Tk::MainWindow->new;
$mw->Label(-textvariable => \$lblvar)->pack(qw/-fill both/);

# Windowが表示されたらタイマ開始
$mw->bind(q/<Expose>/ => sub {
    $mw->after(timergen() , \&append_number);
    $mw->after(timergen() , \&append_alphabet);
});

$mw->MainLoop;

sub timergen
{ int rand 3000 };

sub append
{ $lblvar .= ($lblvar ? ',' : '') . shift; }

sub append_number
{
  return if $num > 10;

  append($num++);
  $mw->after(timergen() , \&append_number);
}

sub append_alphabet
{
  return if $al gt 'J';

  append($al++);
  $mw->after(timergen() , \&append_alphabet);
}

[ Perl ] [ download code ] ]

horiuchi's comment on 疑似並行処理

疑似並行処理 (Nested Flatten)

threadsモジュールを使って実行。 yieldでスレッドが明け渡される場合もあるけど、これくらいのコードだと全部実行されてしまうので sleep 1を入れてます。

use strict;
use threads;

threads->new(sub {
    for (1..10) {
        print $_. "\n";
        sleep 1;
        #threads->yield();
    }
});
threads->new(sub {
    for (my $a = 'A'; $a le 'J'; $a++) {
        print $a. "\n";
        sleep 1;
        #threads->yield();
    }
});

for my $t (threads->list()) {
    $t->join();
}

[ Perl ] [ download code ] ]

匿名's comment on '('と')'の対応

'('と')'の対応 (Nested Flatten)

ものすごく久々にPerlのコードを書いたので怪しいかもしれません

my $PS = chr 40;
my $PE = chr 41;

my $code = <<"XXX" ;
    my \$stack = 0;
    foreach my \$ch $PS unpack "C*", \$input $PE {
        if $PS \$ch == 40 $PE {
            \$stack++;
        } elsif $PS \$ch == 41 $PE {
            \$stack--;
            last if $PS \$stack < 0 $PE;
        }
    }
    $PS \$stack == 0 $PE ? "OK" : "NG";
XXX

my $input = do { local $/; <> };
print STDOUT eval $code, "\n";

[ Perl ] [ download code ] ]

turugina's comment on 世界時計

世界時計 (Nested Flatten)

DateTime と関連モジュールを使って。

use strict;
use warnings;

use DateTime;
use DateTime::TimeZone;
use DateTime::Format::Japanese qw/:constants/;

my $dt = DateTime->now;

my $fmt = DateTime::Format::Japanese->new(
  year_format => FORMAT_GREGORIAN,
  number_format => FORMAT_ROMAN,
  output_encoding => q/sjis/,
);


print_time("現在の時刻", "local", $dt, $fmt);
print_time("グリニッジ標準時", "GMT", $dt, $fmt);
print_time("アメリカ・ロサンゼルスの時刻", "America/Los_Angeles", $dt, $fmt);

sub print_time
{
  my ($desc, $tzname, $dt, $fmt) = @_;

  $dt->set_time_zone( DateTime::TimeZone->new(name => $tzname) );
  print "$desc は @{[$fmt->format_datetime($dt)]} です。\n";
}

[ Perl ] [ download code ] ]

匿名's comment on 漢数字で九九の表

漢数字で九九の表 (Nested Flatten)

やっぱ、use utf8 の 8 もダメだよね…。

use strict; use warnings;

my $utf_hachi;
BEGIN{
    $utf_hachi = 'utf'.length('........');
    require "$utf_hachi.pm";
    $utf_hachi->import
}
$^O =~ /Win\d\d/ ? binmode STDOUT, 'encoding(Shift_JIS)'
                 : binmode STDOUT, $utf_hachi
                 ;

my @字 = (qw/〇 一 ニ 三 四 五 六 七 八 九/);
my @数 = @字;
shift @数;
my @順 = @数;

while( shift @順 ){
    my $段 = scalar(@数) - scalar( @順 );
    my @奄 = @数;
    my $積 = scalar( () );
    while( shift @奄 ){
        $積 += $段;
        $積 =~ /(?<十の位>.)?(?<一の位>.)$/ ;
        my $答 = $+{十の位}? $字[$+{十の位}] : '  ' ;
        $答 .= $字[$+{一の位}] ;
        print "  $答";
    }
    print "\n";
}

__END__

[ Perl ] [ download code ] ]

turugina's comment on π

π (Nested Flatten)

ビジュアル的にはこっちのほうがおもしろい

use strict;
use warnings;

use bignum;

use Memoize;

sub fract
{
  my $n = shift;
  $n == 0 || $n == 1 ? 1 :
  $n * fract($n-1);
}
sub f
{
  my $n = shift;
  $n < 0 ? 0 :
  fract(2 * $n) /
  ((2 ** (4 * $n + 1)) * (fract($n) ** 2) * (2 * $n + 1)) +
  f($n-1);
}
memoize(q/fract/);
memoize(q/f/);

my $N = 1024;

print "@{[6 * f($_)]}\n" for 1 .. $N;

[ Perl ] [ download code ] ]

turugina's comment on π

π (Nested Flatten)

とりあえず、参考ページにあった数式で素直に計算。

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;

[ Perl ] [ download code ] ]

匿名's comment on タブ区切りデータの処理

タブ区切りデータの処理 (Nested Flatten)

標準入力から読込
標準出力への出力

@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/], <> ;

[ Perl ] [ download code ] ]

turugina's comment on 数値リストの圧縮

数値リストの圧縮 (Nested Flatten)

#7713 をperlに移植した感じになりました。

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);

[ Perl ] [ download code ] ]

turugina's comment on 2^i * 3^j * 5^k なる整数

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

[ Perl ] [ download code ] ]

sweetpotato's comment on 比較しないソートの作成

比較しないソートの作成 (Nested Flatten)

バケットソートです。ワンライナーで書いてみました。
最大値と個数は無視します。

1	($n,$x,$c,@s)=@ARGV;$b[$_-$n]++for@s;$b[$_]&&print(($_+$n.' ')x$b[$_])for 0..$#b

[ Perl ] [ download code ] ]

匿名's comment on 起動オプションの解析

起動オプションの解析 (Nested Flatten)

-d は、必須オプションとして処理しています。

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";
}

[ Perl ] [ download code ] ]