Problem 98

CARE という単語の各文字をそれぞれ 1, 2, 9, 6 に置き換えることによって, 平方数 1296 = 362 ができる. 注目すべきことに, 同じ数字の置換をつかうことにより, アナグラムの RACE も平方数 9216 = 962 をつくる. CARE (と RACE) を平方アナグラム単語対と呼ぼう. 先頭のゼロは許されず, 異なる文字が同じ数字をもつこともないとする.
約 2,000 個の一般的な英単語を含む 16K のテキストファイルを用いて, 平方アナグラム単語対をすべて求めよ (回文となる単語はそれ自身のアナグラムとはみなさない).
そのような対のメンバーから作られる最大の平方数は何か?
注: 作られるアナグラムは, すべて与えられたテキストファイルに含まれている.

ファイルはリンク先から.
文字を数字に置き換えて並び替えるという操作をどうやったらいいものかと悩んだけど,問題自体はそれほど難しくなかった.
45秒.必須ではない判定を省いたらもう少し短縮できるかもしれない.

## 単語aに対し数字xの置き換えは正しいか
## - 同じ文字は同じ数字
## - 違う文字は違う数字
is.cor.rep <- function(a, x){
  if(nchar(a) != nchar(as.character(x))) return(FALSE) # 数字と単語の長さが違う
  ## 文字にして1文字ずつベクトルに分解
  a <- unlist(strsplit(a, ""))
  x <- unlist(strsplit(as.character(x), ""))
  ## 数値を文字で呼び出せるようにする
  names(x) <- a
  ## 全部チェック
  flag <- TRUE
  for(i in 1:length(a)){
    ## 同じ文字に違う番号は駄目
    ## x[a[i]]で文字a[i]に対応するxの数値の最初のものが呼び出される
    ## TEST:1234のときi=1, 4だとa[i]="T"でx["T"]となり,"T"に対応する最初の要素1が呼ばれる
    ## i=4のときx[a[i]]は1だがx[i]は4になり,同じ文字に違う数字が入っていることが分かる
    if(x[a[i]] != x[i]){
      flag <- FALSE
      break
    }
    ## 違う文字に同じ番号も駄目
    ## setdiff(a, a[i])でa[i]の文字以外の要素が得られる
    ## これをxの添字に与えて得られる数値のセットとx[i]の数字が被る場合,
    ## 違う文字に同じ番号が割り当てられていることになる
    if(length(intersect(x[i], x[setdiff(a, a[i])])) != 0){
      flag <- FALSE
      break
    }
  }
  return(flag)
}

## 単語としてアナグラムであるか
is.anagram <- function(a, b){
  if(nchar(a) != nchar(b)) return(FALSE) # 数字と単語の長さが違う
  all.equal(sort(unlist(strsplit(as.character(a),""))),
            sort(unlist(strsplit(as.character(b),"")))) == TRUE
}
     
## 数字1つとアナグラムになっている文字列2つを与えたとき,
## 1つめの文字列に数字を対応させ,
## 2つめの文字列に対応するよう並び替えた数字を求める
replace <- function(n, a, b){
  if(!is.anagram(a, b)) return(FALSE) # 単語がアナグラムではない
  if(!is.cor.rep(a, n)) return(FALSE) # 数字と文字の対応が適切ではない
  n <- unlist(strsplit(as.character(n), ""))
  a <- unlist(strsplit(a, ""))
  b <- unlist(strsplit(b, ""))
  names(n) <- a
  if(sort(n[b])[1] == "0") return(FALSE) # 頭が0は駄目
  return(as.numeric(paste(n[b], collapse="")))
}

## 平方数かどうかの判定
is.square.num <- function(n){
  if(!n) return(FALSE)
  sqrt(n) %% 1 == 0
}

## n桁の平方数を全て返す
n.dig.sq <- function(n){
  ifelse(n %% 2 == 0, 
    return((ceiling(sqrt(10^(n-1))):(sqrt(10^n)-1))^2),
    return((ceiling(sqrt(10^(n-1))):sqrt(10^n))^2))
}

## ファイル読み込み
words <- scan("words.txt", what="character", sep=",")

## 要素に分解し要素を整列("BOOK" => "BKOO")
words.ele <- sapply(words, function(x) paste(sort(unlist(strsplit(x, ""))), collapse=""))
## 辞書順ソート
words.e.o <- order(words.ele)
words.ele <- words.ele[words.e.o]
words <- words[words.e.o]
## 長さ順ソート
words.len <- nchar(words)
words.l.o <- order(words.len)
words.ele <- rev(words.ele[words.l.o])
words <- rev(words[words.l.o])

## 解答を求める
i <- 1
j <- 2
ans <- numeric(0)
repeat{
  if(is.anagram(words[i], words[j])){   # 2つの単語がアナグラムのとき
    w.l <- nchar(words[i])
    squares <- n.dig.sq(w.l)            # 長さが同じ平方数全て
    for(n in rev(squares)){             # 平方数全てについて大きいものから調べる
      if(!is.cor.rep(words[i], n)) next # 正しく置き換えられないなら次
      if(is.square.num(m <- replace(n, words[i], words[j]))){ # 置き換えたものも平方数である
        ans <- max(c(ans, n, m))                              # 大きい方を答え候補に
        break                                                 # 終了してokなのか?
      }
    }
  }
  if(nchar(words[i]) > nchar(words[j + 1])){          # 次の単語の方が短いなら
    if(nchar(words[i]) > nchar(words[i + 1])){
      if(length(ans) > 0) break           # 答えが見つかってたら終了
    }
    i <- i + 1
    j <- i + 1
  }else{
    j <- j + 1
  }
  if(i > length(words) || j > length(words)) break
}
ans