DouKaku?

use strict;
use warnings;

if (!@ARGV || length($ARGV[0]) < 2) {
    print "usage: $0 <any word(more than 2-chars)>\n";
    exit 0;
}

my $w = shift;
my $l = length($w);
my $ll = $l * 3 + 1;
my $c = (' ' x $ll . "\n") x $ll;

my @w = split //, $w;
for my $i (0 .. $l-1) {
    substr($c, $l+$i, 1) =
    substr($c, ($ll+1)*$l+$i, 1) =
    substr($c, ($ll+1)*$l+($l*2)+$i, 1) =
    substr($c, ($ll+1)*$l*2+$l-$i, 1) =
    substr($c, ($ll+1)*$l*2+($l*3)-$i, 1) =
    substr($c, -2 - $l - $i, 1) =
    substr($c, ($ll+1)*$i+$l*2, 1) =
    substr($c, ($ll+1)*($l+$i)+$l*3, 1) =
    substr($c, ($ll+1)*($l*2+$i)+$l*2, 1) = 
    substr($c, ($ll+1)*($l*3-$i)+$l, 1 ) = 
    substr($c, ($ll+1)*($l*2-$i), 1) = 
    substr($c, ($ll+1)*($l-$i)+$l, 1) = $w[$i];
}

print $c;

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

#!/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}人を散髪";

use strict;
use warnings;
use Encode;
$,=' ';
print map{sprintf'%08b',$_}
    unpack('C*',
        encode('utf8',
            decode('utf16be',
                pack('C*',
                    map hex,@ARGV))));

srand 0;
print rand

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/ 用のテスト');

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

#! /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();

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

#!/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) };

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

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

}

perl -CIO -Mutf8 -le 'print for map { $_ = sprintf "%06b", $_; tr/01/□■/; $_ } (localtime)[2,1];'

perl -Mutf8 -Mopen=:utf8 -Mopen=:std -E'say for map { $_ = sprintf "%06b", $_; tr/01/□■/; $_ } (localtime)[2, 1];'

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

#!/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;

sub isSteep2{
    my($x,$q) = 0;
    $x < ($q = pop||return 1) ? $x += $q : return 0 while 1;
}

$,="%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);

#!/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;
}

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