還暦爺がAtCoderにPascalで挑戦 入茶しました。

AtCoder始めました～♪

ボケ防止のためにAtCoderに挑戦し始めました。
Delphier(Delphian?) としてはやっぱりPascalでしょ！

しかしながらPascalメインで使っている人は皆無に等しく
昨日のコンテストABC287で提出結果を検索してみると自分以外では
セルビアの人が1人だけで参加者約10000人弱中たった2名のみという超不人気言語です。
これは勉強していく中ではサンプルの数や解説が少なく結構不利かなと
思いますがですがこのまま頑張ってみたいと思います。

コンピュータ歴だけは長い私なのでもうちょっと行けるかなと舐めていましたが
昔やったはずのアルゴリズムもかなり忘れてますし
一応理系学部（通信系）の卒業ですが数学力も不足していて得点の高い問題だと
そもそも問題の意味が分かりません（汗）。

入茶ちゃちゃ♫

何とか茶色に入れました。緑（できれば水色）には行きたいなと考えてます。

Pascal環境♬

さてAtCoderでのPascal事情ですが、現状のバージョンはFreePascal 3.0.4と
なっています。コンパイルのコマンドラインを見ると

fpc -O2 -Sd -Sh -o{dirname}/a.out {dirname}/{basename}

となっています。

オプション	意味
-O2	Level 2 optimizations (-O1 + quick optimizations)
-Sd	Delphi 7 compatibility mode
-Sh	Use reference counted strings (ansistring by default) instead of shortstrings
-o	Change the name of the executable produced to

Delphi7相当、AnsiStringという事で自分的には違和感は無いですが
機能的に最近の言語と比べると不利な面は否めない気がしています。
もうすぐFPC3.2.2に上がるみたいです。このバージョンだとGenerics.Collectionsが
使えるようになるので期待したいと思います。
またFPCのコンパイルエラーは標準出力に出るのでAtCoderのコードテスト画面では
コンパイルエラーを見ることが出来ません。
この点も要望を上げておいたのでバージョンアップ時には解消されることを期待しています。
現状は自前ツールを作って対応しています。

ABC287 A～D問題

最後にABC287ではA～DまでAC（正解）出来たのでソースを上げてみたいと思います。

これは"For"の数を数えて過半数かを判定する問題です。
今まで使ったことが無かったのですが標準入力の読み込みが簡単なんです。

var i,n,cnt : integer;
    s : string;

begin
  readln(n);
  cnt := 0;
  for i := 1 to n do
  begin
    readln(s);
    if s = 'For' then
      inc(cnt);
  end;
  if cnt > (n div 2) then
    writeln('Yes')
  else
    writeln('No');
end.

検査文字列に同じものが複数出てくるのがはまりどころです。
単純にループすると結果が多くなってしまうのでTStringListを使って重複チェックします。
FPCでもTStringList使えるのは助かります。(FPC舐めすぎw)
手抜きでtsをFreeしていませんが実務ではもちろんしないといけません。
配列の大きさをsetlengthで動的に決めていますが個数をn+1にしています。
これは配列を1オリジンとして使ったほうがスッキリするかなと思い
[0]の部分は捨てています。

uses sysutils,classes;

var i,j,n,m,ans : integer;
    s : array of string;
    t : string;
    ts : TStringList;

begin
  readln(n,m);
  setlength(s,n+1);
  ans := 0;
  ts := TStringList.create;
  ts.sorted := true;
  for i := 1 to n do
  begin
    readln(s[i]);
  end;
  for i := 1 to m do
  begin
    readln(t);
    if ts.indexof(t) < 0 then
    begin
      for j := 1 to n do
        if copy(s[j],4,3) = t then
          inc(ans);
    end;
    ts.add(t);
  end;
  writeln(ans);
end.

グラフ問題が出るとちょっとビビッてしまいます。
直近で憶えたUnion-Findを使ってループ検出しています。

uses sysutils,classes;

var i,j,n,m,u,v,c : integer;
    par : array of integer;
    node : array of integer;

// -- union-find --
  procedure inittree(cnt : integer);
  var j : integer;
  begin
    setlength(par,cnt+1);
    for j := 1 to cnt do 
    begin   
      par[j] := j;
    end;

  end;
 
  function root(x : integer) : integer;
  begin
    if par[x] = x then
      result := x
    else
    begin
      par[x] := root(par[x]);
      result := par[x];
    end;
  end;
 
  procedure union(x,y : integer);
  var tmp : integer;
  begin
    x := root(x);
    y := root(y);
    if x > y then
        begin
          tmp := x;
          x := y;
          y := tmp;
        end;
    if x <> y then
      par[y] := x;
  end;
 
  function isSame(x,y : integer) : boolean;
  begin
    result := (root(x) = root(y));
  end;

begin
  read(n,m);
  inittree(n);
  setlength(node,n+1);
  for i := 1 to n do
    node[i] := 0;
  for i := 1 to m do
  begin
    read(u,v);
    if isSame(u,v) then
    begin
      writeln('No');
      exit;
    end;
    union(u,v);
    inc(node[u]);
    inc(node[v]);
  end;
  c := 0;
  for i := 1 to n do
  begin
    if node[i] = 1 then
      inc(c);
    if (node[i] < 1) or (node[i] > 2) or (c > 2) then
    begin
      writeln('No');
      exit;
    end;
  end;
  writeln('Yes'); 
end.

馬鹿正直に書くと当然TLE(CPU時間超過)します（しました）。
x=nとx=n+1の場合にS´文字列の末尾部分の |T|-(n+1)文字部分は同じなので
x=nの場合にその範囲でマッチしていなければn+1でもマッチしないので
判定を飛ばすことが出来ます。
またxでマッチした場合は末尾の同じ部分は判定する必要が無いので
異なる部分から始めることで判定範囲を狭めることが出来ます。

uses sysutils;

var x,l,j,bf,j2,sj : integer;
    s,t,sd : String;
    match : boolean;

  function rightstr(str : string; len : integer) : String;
  begin
    result := copy(str,length(str)-len+1,len);
  end;


begin
  readln(s);
  readln(t);
  l := length(t);
  bf := 1;
  match := true;
  for x := 0 to l do
  begin
    if (not match) and (bf <= l-x) then
    begin
      writeln('No');
      continue;
    end;
    sd := copy(s,1,x) + rightstr(s,l-x);
    match := true;
    begin
      if (l-x >= bf) then
        sj := bf
      else
        sj := 1;
      for j := sj to l do
      begin
        j2 := l-j+1;
        if (sd[j2] <> t[j2]) and (sd[j2] <> '?') and (t[j2] <> '?') then
       begin
          match := false;
          bf := j;
          break;
        end;
      end;
    end; 
    if match then
      writeln('Yes')
    else
      writeln('No');
  end; 

end.

後日追記
D問題の解説を読んだらもっと効率の良い方法があることを知りました。
頭いいなあ！

var s,t : String;
    ls,lt,i,headmatch,tailmatch : integer;

  function isMatch(c1,c2 : char) : boolean;
  begin
    result := (c1 = c2) or (c1 = '?') or (c2 = '?');
  end;
  
  procedure yn(yes : boolean);
  begin
    if yes then
      writeln('Yes')
    else
      writeln('No');
  end;

begin
  readln(s);
  readln(t);
  ls := length(s);
  lt := length(t);
  headmatch := 0;
  tailmatch := 0;
  // 先頭から何文字マッチしているか？
  for i := 1 to lt do
  begin
    if isMatch(s[i],t[i]) then 
      inc(headmatch)
    else
      break;
  end;
  // 末尾から何文字マッチしているか？
  for i := 1 to lt do
  begin
    if isMatch(s[ls-i+1],t[lt-i+1]) then 
      inc(tailmatch)
    else
      break;
  end;

  for i := 0 to lt do
  begin
    yn((i <= headmatch) and (lt-i <= tailmatch));
  end;
end.