ICPCの問題をPerl 6で解いてみる

Perl 6

Higher-Order Perl: Transforming Programs with Programsを読んでいたらなんとなくPerl 6で遊びたくなってきたのでICPC関連の簡単な問題をいくつかPerl 6で解き直してみました。問題はACM/ICPC国内予選突破の手引きのリストのうち上からチョイス。


Hanafuda Shuffle

#! /usr/bin/pugs

loop {
  my ($n, $r) = (in, in);
  last if $n == 0 and $r == 0;

  my @cards = (1..$n).reverse;
  for 1..$r {
    my ($p, $c) = (in, in);
    my @cut = @cards.splice($p-1, $c);
    unshift @cards, @cut;
  }
  @cards.shift.say;
}

exit;

{
  my $line = '';
  sub in {
    $line = =<> if $line eq '';
    return $0 if $line ~~ s/\s*(\S+)\s*//;
    die "No more input";
  }
}

この入力用の in 関数は以降使いまわしです。

When Can We Meet?

#! /usr/bin/pugs

loop {
  my ($n, $q) = (in, in);
  last if $n == 0 and $q == 0;

  my %schedule;
  for 1..$n {
    for 1..in { %schedule{in}++; }
  }

  my $max = %schedule.keys.map:{ [ $^k, %schedule{$^k} ] }.reduce:{ $^x[1] > $^y[1] ?? $^x !! $^y };
  say $max[1] >= $q ?? $max[0] !! 0;
}

exit;

{
  my $line = '';
  sub in {
    $line = =<> if $line eq '';
    return $0 if $line ~~ s/\s*(\S+)\s*//;
    die "No more input";
  }
}

maxをreduceで求めてみるテスト。正直微妙。

Get Many Persimmon Trees

#! /usr/bin/pugs

loop {
  my $n = in;
  last if $n == 0;
  my ($w, $h) = (in, in);

  my %field;
  %field{ join ',', in, in } = 1 for 1..$n;

  my ($s, $t) = (in, in);
  my $max = 0;
  for 1..$w -> $x {
    for 1..$h -> $y {
      my $count = 0;
      for 0..$s-1 -> $dx {
        for 0..$t-1 -> $dy {
          $count += %field{ join ',', $x+$dx, $y+$dy };
        }
      }
      $max = $count if $count > $max;
    }
  }

  say $max;
}

exit;

{
  my $line = '';
  sub in {
    $line = =<> if $line eq '';
    return $0 if $line ~~ s/\s*(\S+)\s*//;
    die "No more input";
  }
}

実直に。

Numeral System

#! /usr/bin/pugs

my %table = < m 1000   c 100   x 10   i 1 >;
my @keys_in_order = <m c x i>;

{
  my $n = in;

  for 1..$n {
    my ($s1, $s2) = (in, in);
    my $sum = to_int($s1) + to_int($s2);

    for @keys_in_order -> $k {
      my $v = %table{$k};

      my $q = int($sum / $v);
      $sum = $sum % $v;

      print $q if $q > 1;
      print $k if $q > 0;
    }
    say;
  }
}

exit;

sub to_int ($str) {
  my $copy = $str;

  my $sum = 0;
  $sum += ($0 ne '' ?? $0 !! 1) * %table{$1} while $copy ~~ s/ (\d?) (<alpha>) //;
  return $sum;
}

{
  my $line = '';
  sub in {
    $line = =<> if $line eq '';
    return $0 if $line ~~ s/\s*(\S+)\s*//;
    die "No more input";
  }
}

regexの記法がかなり変わっていて分かりません。[a-z]でcharacter classは作れなくなったのか…。

Sum of Different Primes

#! /usr/bin/pugs

my @p;
for 2..1120 -> $x { push @p, $x if $x % all(@p) != 0; }

loop {
  my ($n, $k) = (in, in);
  last if $n == 0 and $k == 0;

  solve($n, $k, 0).say;
}

exit;

{
  my %cache;
  sub solve ($n, $k, $idx) {
    return 1 if $n == 0 and $k == 0;
    return 0 if $n == 0 or $k == 0;

    my $key = join ',', $n, $k, $idx;
    if not defined %cache{$key} {
      my $count = 0;
      for $idx..@p-1 -> $i {
        last if @p[$i] > $n;
        $count += solve($n - @p[$i], $k - 1, $i + 1);
      }
      %cache{$key} = $count;
    }
    return %cache{$key};
  }
}

{
  my $line = '';
  sub in {
    $line = =<> if $line eq '';
    return $0 if $line ~~ s/\s*(\S+)\s*//;
    die "No more input";
  }
}

素数の配列が1行で作れるのは気持ちがいい。ジャンクションはなかなか使い勝手がいいですね。この問題を走らせると，実行速度が明らかに C >> Perl 5 >>>> Pugs なのが手に取るように分かって，Pugsで 1120 14 はメモ化しているのにも関わらず止まりません…。

Keitai Message

#! /usr/bin/pugs

my @table = (
  [<. , ! ?>, ' '],
  [<a b c>],
  [<d e f>],
  [<g h i>],
  [<j k l>],
  [<m n o>],
  [<p q r s>],
  [<t u v>],
  [<w x y z>],
);

{
  my $n = in;

  for 1..$n {
    my @x = split '', in;

    while @x {
      my $num = @x.shift or next;
      my $seq = 0;
      $seq++ while @x.shift;
      @table[$num-1][ $seq % @table[$num-1] ].print;
    }
    say;
  }
}

exit;

{
  my $line = '';
  sub in {
    $line = =<> if $line eq '';
    return $0 if $line ~~ s/\s*(\S+)\s*//;
    die "No more input";
  }
}

Perl 5の qw() が <> で書けるようになった点は意外と便利。