KLab若手エンジニアの これなぁに?

KLab株式会社の若手エンジニアによる技術ブログです。phpやRubyなどの汎用LLやJavaScript/actionScript等のクライアントサイドの内容、MySQL等のデータベース、その他フレームワークまで幅広く面白い情報を発信します。

Haskell

IRCボットコンテストエンリ 最終兵器Haskellによるゲームボット

こんにちは夏です。takada-atです。 夏こそ純粋関数型言語ですね(謎)。 みなさまどうぶつしょうぎというゲームをごぞんじでしょうか? http://ja.wikipedia.org/wiki/どうぶつしょうぎ 子どもへの将棋普及のために考えられた簡易版の将棋風ゲームです。 以前社内でこのゲームが流行していた時期に、HaskellによるAIを開発しました。 今回はそのAIとIRC上で対戦できるようにしました。 なんとIRC上でどうぶつしょうぎの対戦ができてしまうゲームAIボットです。アスキーアートによるインターフェースがあまりに素朴なので、思わず昔をなつかしんで故郷の両親に電話をかけてしまう、などの効果もあるのではないかと自負しています。 盤面はこういう感じで表示されます。
21:03 (takada-at) !ds-start
21:03 (dshogi) __A__B__C_
21:03 (dshogi) 1-KR-LI-ZO
21:03 (dshogi) 2 * -HY * 
21:03 (dshogi) 3 * +HY * 
21:03 (dshogi) 4+ZO+LI+KR
21:03 (dshogi) []
21:03 (dshogi) []
!ds-move XXX という発言で、自分の手を操作します。 たとえば、C4にある駒をC3に動かしてみましょう。
21:04 (takada-at) !ds-move C4C3
21:04 (dshogi) __A__B__C_
21:04 (dshogi) 1-KR-LI-ZO
21:04 (dshogi) 2 * -HY * 
21:04 (dshogi) 3 * +HY+KR
21:04 (dshogi) 4+ZO+LI * 
21:04 (dshogi) []
21:04 (dshogi) []
21:04 (dshogi) __A__B__C_
21:04 (dshogi) 1 * -LI-ZO
21:04 (dshogi) 2-KR-HY * 
21:04 (dshogi) 3 * +HY+KR
21:04 (dshogi) 4+ZO+LI * 
21:04 (dshogi) []
21:04 (dshogi) []
すぐにAIが対抗する手を打ってきます。 すべてのコマンドは、!ds- というプレフィックスではじまります。 !ds-help と発言すれば、ヘルプを表示します。 実装の詳細には踏み込みませんが、AIは深さ優先探索です。 Haskellをつかったことないと意味不明だと思いますが、盤面の状態、乱数の種などなどをStateモナドで持ち回す感じの実装になってます。 HaskellによるIRCボットの実装については以下を参考にしました。 http://www.haskell.org/haskellwiki/Roll_your_own_IRC_bot あとIRCメッセージのパーサーライブラリを利用しています。 http://hackage.haskell.org/package/irc

■使い方

dshogi.conf を適当に編集して、サーバーとかチャンネルを指定します。 以下のコマンドで実行します。 念のためWindows環境でビルドしたexeファイルとLinux環境でビルドしたバイナリの両方をつけました。 ./DshogiIRC dshogi.conf

■ビルド方法

万が一ビルドしてみたい方がいれば以下の方法でお願いします。 ちなみに手元の環境では、ghcのバージョンは6.12.1。ircライブラリだけインストールすればビルドできました。
runhaskell Setup.hs configure
runhaskell Setup.hs build
cp dist/build/DshogiIRC/DshogiIRC .
ソースコードは以下にあります。 http://lab.klab.org/young/wp-content/uploads/data/code/dshogi.tar.gz

エコーサーバー改良版

takada-atです。 前回HaskellおよびRubyでエコーサーバーを発表したところ、エコーサーバーおよびネットワークプログラミングの基礎について、社内でいろいろな指摘を受けました。 今回は、指摘された点をひとつひとつ改良していきたいと思います。 リンク: Haskellでエコーサーバー

ポート番号

実は恥しながらRFCにエコーサーバーの規定があるのを知らなかったのですが、一般に「エコーサーバー」と言った場合、正式には「RFC862 - Echo Protocol」のサーバー実装を指すことが多いようです。 http://www.faqs.org/rfcs/rfc862.html RFC862では、エコープロトコルのポート番号に 7 を割り当てています。
A server listens for TCP connections on TCP port 7.
もちろん1024以下のポート番号を利用するには、ルート権限が必要ですが、可能ならポート番号7を利用することが望ましいでしょう。

forkについて

forkしたあと、親プロセスでハンドラを閉じていないという指摘を受けましたが、これは誤解で、GHCの「forkIO」「forkOS」は、forkシステムコールとは無関係な、スレッドを新たに生成する関数です。名前が少しまぎらわしいですね。 なお余談ですが「forkIO」は疑似スレッド、「forkOS」はネイティブスレッドを生成します。 さらに余談ですが、http://ja.wikipedia.org/wiki/食事する哲学者の問題って、ひょっとして「フォーク」と「fork」をかけてるんですかね? 大発見だと思ったんですが、全然関係ない上に間違ってますか、そうですか……。 参考リンク: Control.Concurrent

シグナルハンドリングについて

いくつかのシグナルをハンドリングしておかなければ、クライアントの動作によってサーバー自体がダウンしてしまいます。 特に危険なのがSIGPIPEです。 ソケットに対し、書き込みを行なった場合、相手側がすでにclose状態だとこのシグナルが発生します。デフォルトの動作ではプロセスが強制終了してしまいます。 参考リンク: シグナル (ソフトウェア) - Wikipedia SIGPIPE - Wikipedia, the free encyclopedia 以上をふまえた上で、高レベルAPIを提供するNetworkライブラリではなく、より低レベルなNetwork.Socketライブラリを使うように書き換えてみます。 main部分は以下のように変わりました。

main = withSocketsDo $ do
         let port = fromIntegral 7
         soc <- socket AF_INET Stream 0
         addr <- inet_addr "0.0.0.0"
         let sockaddr = SockAddrInet port addr
         bindSocket soc sockaddr
         listen soc 5
         -- mainスレッドではいくつかのシグナルをブロック
         blockSignals $ list2set [sigPIPE]
         putStrLn $ "start server, listening on: " ++ show port
         acceptLoop soc `finally` sClose soc

list2set = foldr addSignal emptySignalSet

read, writeについて

以前のバージョンではソケットからの読み込み・書き込みにhGetLine, hPutStrLnを利用していたのですが、これを使うと、サーバー・クライアント間の改行コードの違いなどによって問題が発生しうるという指摘を受けました。 エコープロトコルの実装としては、行ごとの読み込みではなく、文字列をすぐ読み込んで書き込む方が望ましいでしょう。

def echo_do(soc)
    while true
        buf = soc.recv(1)
        soc.write(buf)
    end
end

テスト

以上の動作確認をtelnetを手動で立ち上げて確認するのではなく、Rubyによるテストスクリプトを作成し、こちらで動作確認を行なうことにしました。

require 'test/unit'
require 'socket'

class EchoTest < Test::Unit::TestCase
    def test_echo
        #エコーのテスト
        soc = TCPSocket::new("localhost", 7)
        ["abc", "ab\na", "\n"].each do |s|
            soc.write(s)
            buf = soc.read(s.size)
            assert_equal(s, buf)
            puts buf
        end
        soc.close
    end
    def test_concurrent
        #同時接続のテスト
        socs = []
        3.times do |i|
            Thread::fork(i,socs){ |i, socs|
                sleep 0.1
                soc = TCPSocket::new("localhost", 7)
                s = "hoge"
                soc.write(s)
                buf = soc.read(s.size)
                assert_equal(s, buf)
                puts buf
                socs << soc
            }
        end
        (ThreadGroup::Default.list - [Thread.current]).each {|th| th.join}
        socs.each {|s| s.close}
    end
end

ソースコード

Haskell版とRuby版、修正したものを以下に掲載します。 なお、Haskell版のコンパイルはthreadedオプションを付け以下のようにやってください。
ghc -threaded --make -o echo2 echo2.hs

-- | an implementation for rfc862 Echo Protocol
-- http://www.rfc-editor.org/rfc/rfc862.txt

module Main where
import Network.Socket
import System.IO
import System.Posix.Signals --syghandling
import Control.Exception
import Control.Concurrent
import Prelude hiding (catch)



main = withSocketsDo $ do
         let port = fromIntegral 7
         soc <- socket AF_INET Stream 0
         addr <- inet_addr "0.0.0.0"
         let sockaddr = SockAddrInet port addr
         bindSocket soc sockaddr
         listen soc 5
         -- mainスレッドではいくつかのシグナルをブロック
         blockSignals $ list2set [sigPIPE]
         putStrLn $ "start server, listening on: " ++ show port
         acceptLoop soc `finally` sClose soc

list2set = foldr addSignal emptySignalSet



acceptLoop soc = do
  (nsoc, addr) <- accept soc
  forkOS $ echoLoop nsoc
  acceptLoop soc


echoLoop soc = do
  --メインスレッドで無視してたシグナルをunblock
  unblockSignals $ list2set [sigPIPE]
  sequence_ (repeat (do { -- ioアクションの無限リスト
                          (buff,_,_) <- recvFrom soc 1;
                          send soc buff
                     }))
  `catch` (\(SomeException e) -> return ())
  `finally` sClose soc

require 'socket'
def main
    soc = Socket.new(Socket::AF_INET, Socket::SOCK_STREAM, 0)
    sockaddr = Socket.sockaddr_in(7, "0.0.0.0")
    soc.bind(sockaddr)
    soc.listen(5)
    puts "start server, listening on 7"

    #sigpipeを無視
    Signal::trap(:PIPE, "SIG_IGN")

    accept_do(soc)
end

def accept_do(serv)
    while(true)
        soc, addr = serv.accept
        Thread.new(soc, &self::method(:echo_do))
    end
end
def echo_do(soc)
    while true
        buf = soc.recv(1)
        soc.write(buf)
    end
end

main if($0==__FILE__)

Haskellでエコーサーバー

Haskellで、TCPのサーバーを書いてみたいと思い、手始めにエコーサーバーを書いてみました。 エコーサーバーというのは、クライアントからの入力をそのまま返すサーバーです。 以下の記事を参考にもっと簡単なものを作ってみます。 A simple TCP server | The Haskell Sequence
main = withSocketsDo $ do
         [p] <- getArgs
         let port = fromIntegral (read p :: Int)
         soc <- listenOn $ PortNumber port
         putStrLn $ "start server, listening on: " ++ show port
         acceptLoop soc `finally` sClose soc
main部分です。 ソケットを開いてlistenします。
acceptLoop soc = do
  (hd, host, port) <- accept soc
  forkOS $ echoLoop hd
  acceptLoop soc
mainのあとの処理です。 クライアントがきたら、accept(受け付け)して、新しいスレッドを生成し、そちらに処理を任せます。 新しいクラアントに対応しつづけるため、処理が終わってはいけませんので、こちらは無限ループを続けます。
echoLoop hd = do
  sequence_ (repeat (do { -- ioアクションの無限リスト
                          l <- hGetLine hd;
                          hPutStrLn hd l;
                          hFlush hd
                     }))
  `catch` (\(SomeException e) -> return ())
  `finally` hClose hd
クライアントごとの処理です。 こちらは、一行読み込んで一行そのまま書き込むという処理を繰り返しているだけです。 さっそく実行してみましょう。
$ ghc -o echoHS -O --make -threaded echosimple.hs
$ ./echoHS 8080
start server, listening on: 8080
別のコンソールをひらきアクセスしてみます。
$ telnet localhost 8080
hoge
hoge
aiu
aiu


できました! 30行程度で、エコーサーバーが完成しました。 ついでにRubyでも同じものを書いたのでそちらも掲載しておきます。
module Main where
import Network
import Monad
import System.IO
import System.Environment (getArgs)


import Control.Exception
import Control.Concurrent
import Prelude hiding (catch)


main = withSocketsDo $ do
         [p] <- getArgs
         let port = fromIntegral (read p :: Int)
         soc <- listenOn $ PortNumber port
         putStrLn $ "start server, listening on: " ++ show port
         acceptLoop soc `finally` sClose soc


acceptLoop soc = do
  (hd, host, port) <- accept soc
  forkOS $ echoLoop hd
  acceptLoop soc


echoLoop hd = do
  sequence_ (repeat (do { -- ioアクションの無限リスト
                          l <- hGetLine hd;
                          hPutStrLn hd l;
                          hFlush hd
                     }))
  `catch` (\(SomeException e) -> return ())
  `finally` hClose hd

require 'socket'
def main
    unless ARGV[0]
        puts "usage: #{$0} PORTNUMBER"
        exit(true)
    end
    soc = Socket.new(Socket::AF_INET, Socket::SOCK_STREAM, 0)
    sockaddr = Socket.sockaddr_in(ARGV[0].to_i, "0.0.0.0")
    soc.bind(sockaddr)
    soc.listen(5)
    puts "start server, listening on #{ARGV[0]}"
    accept_do(soc)
end

def accept_do(serv)
    while(true)
        soc, addr = serv.accept
        puts "new client"
        Thread.new(soc, &self::method(:echo_do))
    end
end
def echo_do(soc)
    while true
        buf = soc.gets
        puts "data: #{buf}"
        soc.puts(buf)
    end
end

main if($0==__FILE__)

天下一プログラマー本戦1問目の解説

天下一プログラマー実行委員の takada-at です。 今回は、本戦1日目の1問目にあたる「障害物ありNクイーン」を紹介します。

解答

20
-Q--*******Q----
---Q*******--Q--
----******-----Q
-----****Q------
-----***------Q-
------*-Q-------
----------Q*****
Q---------******
--Q-------******
----------Q*****
-----Q*Q--------
-----***-----Q--
----Q****------Q
----******--Q---
----*******---Q-
----*******Q----

問題について

エイト・クイーン・パズルの変形版です。問題文にある通り、他のクイーンが一手で移動できるマスを避け、盤面上にクイーンを置いていきます。
 ----*******-----
 ----*******-----
 ----******------
 -----****-------
 -----***--------
 ------*---------
 -----------*****
 ----------******
 ----------******
 -----------*****
 ------*---------
 -----***--------
 -----****-------
 ----******------
 ----*******-----
 ----*******-----
まず素朴にこのパズルを解く方法を考えてみましょう。 以下では、縦のラインを「列」、横のラインを「行」と呼ぶことにします。 左からi列目、上からj行目のマスを(i,j)と書きます。i,jは0から数えます。 各行に対し、左から右、上の行から下の行へクイーンを置いていくとしましょう。 最初に(0,0)に置いた場合、このクイーンの経路には他のクイーンは置けませんから、次にクイーンを置けるマスは(12,0)、さらにその次に置けるのは(2,0)となります。 最初に(1,0)に置いた場合は、次にクイーンを置けるマスは(12,0)、さらにその次に置けるのは(3,0)となります。 -最初に(0,0)に置いた場合
Qxxx*******Qxxxx
xxQx*******-----
-最初に(1,0)に置いた場合
xQxx*******Qxxxx
xxxQ*******-----
このように、「(0,0)に置く? / 置かない?」「(0,1)に置く? / 置かない?」というそれぞれの選択肢が運命の分かれ道となり、それによってその後にクイーンを置けるマスが変わっていきます。左側の矢印を「置く」、右側の矢印を「置かない」として、次に置けるマスを図示しますと、以下のようになります。 問題は、これらの経路の内、「置く」を選んだ回数が最大のものを探すことです。

アルゴリズム

このようなグラフの探索問題を解くアルゴリズムにはいくつかバリエーションがありますが、ここでは「深さ優先探索」を使います。 他にも代表的なアルゴリズムとして「幅優先探索」がありますが、エイト・クイーンのような問題の場合、考慮すべき経路の量が多く、ふさわしくありません。 http://ja.wikipedia.org/wiki/深さ優先探索 http://ja.wikipedia.org/wiki/幅優先探索 深さ優先探索の実装は、スタックを利用するか再帰を利用するのが一般的です。 Rubyで再帰を利用した場合の探索部分を以下に示します。
def depthFirst x, y, h
    return h if (h[:map].size==y) #それ以上行がないので終了
    max = h
    x.upto(h[:map][y].size-1) do |x1| 
    # y行目でx列目より右の、クイーンを置くことができるマスのそれぞれについて...
        next if h[:map][y][x1] != BRANK
        nmap = deepcopy(h[:map])
        setQueen(nmap, [x1,y])
        #クイーンを置いてみて、その後の運命を見定める
        r = depthFirst(x1+1, y, {:map=>nmap, :count=>h[:count]+1}) 
        #最大のものをとる
        if(max[:count] < r[:count])
            max = r
        end
    end
    #あえて置かないという選択肢も調べる
    r = depthFirst(0, y+1, h)
    if(max[:count] < r[:count])
        max = r
    end
    max
end
日本語で書くと以下のようになります。
  • y行目でx列目より右で、クイーンを置くことができるマスのそれぞれについて、
    • とりあえずクイーンを置いてみて、その右のマスに対し同じ操作を繰返す
    • それぞれの結果の内最大のものを取る
  • 行の右端まで行ったら下の行へ行く
  • それ以上行がなくなったら終了
あとはデータ構造です。 単純に考えれば盤面は二重配列にするのがよいでしょう。最適化を考え、ビットの配列にしてもよいですが、「何もない場合」「障害物」「クイーン」「クイーンの経路」といった状態が考えられるため、ビットの配列を複数持つ必要があります。 また、クイーンの数を比較するため、クイーンの合計数を盤面とは別に持つのもよいでしょう。

最適化

さて、以上を実装して解答が出れば話は簡単なのですが、この問題の場合、計算量の多さがネックになります。 素朴に解こうとすると一時間では計算が終わらないということにもなりかねません。 そこで、いくつか最適化の手段を考えていきましょう。 まず何度も繰り返すことになるクイーンの配置を最適化します。すべてのマスに対するクイーンの経路をあらかじめ計算してキャッシュ(メモ化)おきましょう。 あらかじめ計算しておけば、すべてのマス(障害物以外)を一度ずつ処理するだけで済みます。 経路の探索中は、同じマスに対し何度も何度もクイーンを配置する処理が必要になりますから、計算結果のキャッシュが有効にはたらくはずです。 さらに言えば、左から右、上から下に処理していくため、クイーンの経路は「右、右下、下、左下」の4つのみ考慮すれば済みます。左上や左にすでにクイーンがあった場合はそもそもそのマスにはクイーンを配置できません。
--x-*******-----
---xx****-------
xxxxQx*---------
---xxx-----*****
--x-x-x---******
左上、左、上にクイーンがないことはすでに確定しているため、考慮しなくていい。
また、以下のようなメモ化も考えられます。 パターン1とパターン2は違う盤面ですが、下から2つの行だけを見ると、同じ状態になっています。 ということは、下から2つの行を処理をする際にはどちらの場合でも同じ結果が出てくるはずです。つまり、「残りの行」の状態をキーにして結果をキャッシュして置くことで、いくつかの分岐を省略することができます。 とりわけ探索の後半は、ほとんどクイーンの経路で塗りつぶされた盤面を処理することになるはずですから、この処理が有効なはずです。 ただし、これによってメモリを食うことにもなるので、どの程度このキャッシュを働かせるかは微妙な選択でしょう。実際、言語によっては、このメモ化をしない場合の方が速くなることもありました。
---Q
Qxxx
xxQx
xxxx
x-xx
xxxx
パターン1
----
--Qx
Qxxx
xxxQ
x-xx
xxxx
パターン2
この探索の場合、網羅性を考えると、最適な配置のために「置ける場所にあえてクイーンを置かない」という選択肢も検討する必要があります。しかし、これによって探索する経路が大分増えてしまうのも事実です。 仮に「あえて置かない」選択肢を取らなかった場合の計算量が「n の m乗」(選択肢の数+深さ)だったとすると、「あえて置かない」選択肢を追加することで、概算で「(n+1) の m乗」にまで経路が増えてしまいます。 さらに言えば、「この行にはあえて置かない」という選択を10回繰り返したあとの経路などは、クイーンの数が最大になるとは考えづらいため、検討する必要がないものです。 よって、「あえて置かない」選択肢の回数を制限することにしましょう。この場合網羅性を犠牲にしているので、「クイーンの数が最大であること」を示さなければなりません。しかし「あえて置かない」選択肢の許容量を順次増やしていくことで最大の解を検討することもできるはずです。ところでその際、90度回転してから探索をはじめた方が都合がよくなります。これはこの盤面の特性によります。 障害物で分断された行(or列)のそれぞれを「ブロック」と呼ぶことにしましょう。縦のラインには、22ブロック(2つに分割された列が6、分割されていない列が10)あります。横のラインには、28ブロック(2つに分割された行が12、分割されていない行が4)あります。 縦または横のラインだけを見ていっても、1ブロックにクイーンを1つしか置けないのはあきらかです。つまり、縦のラインを見ていくと、この盤面におけるクイーンの最大値は22であることが明らかになります。縦のラインの方が最大値が低いため、横回転して縦のラインを基準に考えた方がよいのです。 実際には、この盤面の場合、「あえて置かない」選択肢の数は1回で十分であることがわかります。 計算を実行してみると、以上の最適化を組み合わせることで、Rubyでも10分程度、Haskellなどでは5分以下で解にたどりつくことができました。 解は以下のようになります。
20
-Q--*******Q----
---Q*******--Q--
----******-----Q
-----****Q------
-----***------Q-
------*-Q-------
----------Q*****
Q---------******
--Q-------******
----------Q*****
-----Q*Q--------
-----***-----Q--
----Q****------Q
----******--Q---
----*******---Q-
----*******Q----
この盤面が最大であることの証明は以下のようになります。 縦のラインに注目しましょう。クイーンが置かれていないブロックは(6,j)の列と、右から4列目、(11,j)の列だけです。ということは、もしクイーンを増やせるとしても、最大で2つにとどまります(1ブロックにクイーンを1つ以上置くことはできません)。 つまり余地が一つしかない以上、「2ブロック見逃す」という選択肢を考慮することで、置けるクイーンの数が増えることはありえません(理論上の最大値が22である以上、2つ見逃した時点で、20を超えることはないはずです)。 以上より、この解が最適解の1つであることがわかりました。 Ruby, Python, Haskellによるコードの例を以下に掲載します。 (Haskellは解答用言語に含まれていませんでしたが、おまけです)。 ---- haskell

{-# OPTIONS_GHC -O #-}
module Main where
import Array
import Data.List hiding (lookup, insert)
import Data.HashTable
import Time
import Control.Monad.Reader
import Prelude hiding (lookup)


type Node = (Int, Int)
data Board =  Board{count, miss :: Int, board :: Map}



{-- Term --}
data Term = Queen | Obstacle | Brank | Route deriving Eq
instance Show Term where
    showsPrec d t = showParen (d > 10) $ showString (showTerm t)

showTerm Brank  = "-"
showTerm Obstacle = "*"
showTerm Queen  = "Q"
showTerm Route  = "-"


showTermInternal Route  = "x"
showTermInternal t  = showTerm t

isBrank Brank = True
isBrank _ = False

isObstacle Obstacle = True
isObstacle _ = False

instance Read Term where
    readsPrec _ s = [(readTerm s, "")]

readTerm "-" = Brank
readTerm "*" = Obstacle
readTerm "Q" = Queen
readTerm "+" = Route
readC c = read [c]

{-- Map --}
data Map = Map {width, height :: !Int , points :: !(Array Node Term)}
instance Show Map where
    showsPrec d m = showParen (d>10) $ showString $ showMap m
instance Show Board where
    showsPrec d m = showParen (d>10) $ showString $ showBoard m
showMap :: Map -> String
showMap m = do r <- rows $! points m
               ( concatMap show r ) ++ "\n"
instance Read Map where
    readsPrec _ str = [(readMap str, "")]
readMap :: String -> Map
readMap str = Map w h $! array bnd $! vals
        where
          ls = lines str
          bnd = ((0,0),(w-1,h-1))
          w = length . head $ ls
          h = length ls
          vals = zip ([(x,y)|y <- [0..h-1], x<-[0..w-1]]) (map readC $ filter (/= '\n') str)

showBoard m = unlines [show (count m), show (board m)]


rowsFrom :: Array Node c ->Int-> [[c]]
{-# INLINE rowsFrom #-}
rowsFrom x l = [row i x | i <- range (l, u)]
    where (_, (_,u)) = bounds x
rowsTo :: Array Node c ->Int-> [[c]]
rowsTo x u = [row i x | i <- range (l, u-1)]
    where ((_,l), _) = bounds x

rows :: (Ix a, Ix b) => Array (a,b) c -> [[c]]
{-# INLINE rows #-}
rows x = [row i x | i <- range (l',u')]
    where ((_,l'),(_,u')) = bounds x


row :: (Ix a, Ix b) => b -> Array (a,b) c -> [c]
{-# INLINE row #-}
row i x = [x ! (ix, i) | ix <- range (l', u')]
    where ((l',_),(u',_)) = bounds x

rowIdx :: (Ix a, Ix b) => b -> Array (a,b) c -> [((a,b), c)]
{-# INLINE rowIdx #-}
rowIdx i x = [((ix,i), (x ! (ix, i))) | ix <- range (l', u')]
    where ((l',_),(u',_)) = bounds x

at :: Map -> (Int, Int) -> Term
{-# INLINE at #-}
at m (x,y) = (points m) ! (x,y)




{-- route --}
route :: Int -> Int -> Node -> [[Node]]
route w h (x,y) =
    [
     zip right (repeat y),
     zip right down,
     zip (repeat x) down,
     zip left down
    ]
    where
      left = [(x-1),(x-2)..0]
      right = [(x+1),(x+2)..(w-1)]
      up = [(y-1),(y-2)..0]
      down = [(y+1),(y+2)..(h-1)]


forRoute :: Map -> ((Int,Int) -> a) -> (Int,Int) -> [a]
forRoute m@Map{width=w,height=h} f (x,y) = do l <- route w h (x,y)
                                              map f $ takeWhile (not . isObstacle . (at m)) l

setQueen :: (Int, Int) -> Map -> Maybe Map
setQueen i@(x,y) m = if isBrank (at m i)
                     then
                         Just m {points = (points m) // ((i,Queen):values)}
                     else Nothing
    where
      values :: [((Int,Int), Term)]
      values = forRoute m set (x,y)
      set :: (Int,Int) -> ((Int,Int), Term)
      set j = (j, Route)

compareBoard :: Board -> Board -> Ordering
compareBoard Board {count=c1} Board {count=c2} = compare c1 c2

maxBoard :: Board -> Board -> Board
{-# INLINE maxBoard #-}
maxBoard x y = if count x >= count y then x else y
{-- memo --}
type RouteMemo = HashTable String [(Node, Term)]
type MapMemo = HashTable String (Int, Int, Array Node Term)
data Memo = Memo{mapMemo :: !MapMemo, routeMemo :: !RouteMemo}
type Memoise a = ReaderT Memo IO a
setQueenM :: Node -> Map -> Memoise (Maybe Map)
setQueenM i@(x,y) m =
    if isBrank (at m i) then
        do {
          memo <- asks routeMemo;
          Just rt <- liftIO $! (lookup memo (show i));
          return $! Just m{points = (points m) // ((i,Queen):rt)}}
    else return $! Nothing
makeRouteMemo :: Map -> IO (HashTable String [(Node, Term)])
makeRouteMemo mp = let w = width mp
                       h = height mp in
                   do hash <- new (==) hashString
                      setHash hash mp
                      return $! hash
    where
      setHash hash mp =
          let w = width mp
              h = height mp in
          sequence $!
          map (\p-> let (n,v) = p in
                     if v == Brank then
                         insert hash (show n) $!
                                zip (concat $! (map (takeWhile ((/=Obstacle).(at mp)))) $! route w h n)
                                    $ repeat Route
                     else return ()
               ) $! assocs $! points mp

memoKey :: Int -> Map -> String
{-# INLINE memoKey #-}
memoKey l m = do r <- (rowsFrom $! (points m)) l
                 (concatMap showTermInternal $! r)++"\n"
countUnder :: Int -> Board -> Int
{-# INLINE countUnder #-}
countUnder l Board{board=mp} = foldl (\x _-> x+1) 0 (filter (==Queen) (concat (rowsFrom (points mp) l)))
countAbove :: Int -> Board -> Int
{-# INLINE countAbove #-}
countAbove l Board{board=mp} = foldl (\x _-> x+1) 0 (filter (==Queen) (concat (rowsTo (points mp) l)))

copyUnder :: Int -> Array Node Term -> Map -> Map
copyUnder l pts m@Map{points=d} =
    case (d //)
           $! ([n | i<-range (low,(l-1)), n<-rowIdx i d]) ++
              assocs pts of
      npts -> m{points=npts}
    where
      ((_,low),(_,hi)) = bounds d
lookupMemo :: String -> Board -> Memoise (Maybe Board)
lookupMemo key bd@Board{board=mp} =
    do {
      memo <- asks mapMemo;
      r <- liftIO (lookup memo key);
       case r of {
                Just (cnt, y, pts) ->
                --do liftIO (putStrLn "lookup")
                    do
                      nar <- return $! copyUnder y pts mp
                      return $! (Just bd{count=cnt+(countAbove y $! bd),
                                                 board=nar})
                ;Nothing ->
                    return $! Nothing}}
insMemo :: Int -> String -> Board -> Memoise ()
insMemo y key bd@Board{board=mp} =
    let ((lx,ly),(hx,hy)) = bounds (points mp)
        nbnd = ((lx, y),(hx,hy))
        memo = array nbnd $! filter ((>=y).snd.fst) $! assocs (points mp) in
    do t <- asks mapMemo;
       return $! t `seq` memo `seq` y ;
       nct <- return $! countUnder y $! bd;
       liftIO(insert t key (nct, y, memo));
       t `seq` return ();


{--- 深さ優先 ---}
incMiss :: Board -> Board
incMiss b = b{miss=(miss b)+1}
deepFirst :: Int -> Board -> Memoise Board
deepFirst y r | y==(height (board r)) = return $! r
deepFirst _ r | miss r >= 5 = return $! r
{--
キャッシュすると余計重くなるのでやめた
deepFirst y route@Board{board=bd} |y>=12 =
    let key = memoKey y bd in
    do {
      memo <- (lookupMemo $! key) $! route;
      case memo of {
         Just m -> return $! m;
         Nothing -> do {
                      mx <- deepFirstIter 0 y route;
                      insMemo y key $! mx;
                      return $! mx
                    }}}
--}
deepFirst y r =
    deepFirstIter 0 y r


deepFirstIter :: Int -> Int -> Board -> Memoise Board
deepFirstIter x y route@Board{board=bd,count=ct} =
    let line = filter ((>=x).fst.fst) $! rowIdx y (points bd) in
    case filter ((==Brank).snd) $! line of
      [] -> (deepFirst (y+1)) $! route
      ls -> do {
              res <- mapM (\n ->
                           let ((x',_),_) = n in
                           do {
                             Just m <- setQueenM (x',y) bd;
                             m <- return $! m;
                             deepFirstIter (x'+1) y route{board=m,count=ct+1}}
                          ) ls;
              res2 <- (deepFirst (y+1)) $! (incMiss route); --あえて置かない
              res2 <- return $! res2;
              return $! foldl1' maxBoard $! (res2:res)
              --return $! foldl1' maxBoard $! res
            }


searchD :: Map -> IO (Int, Map)
searchD m =
    do hash <- makeRouteMemo $! m
       hash2 <- new (==) hashString
       b <- runReaderT (deepFirst 0 (Board 0 0 m)) ((Memo hash2) $! hash)
       return (count b, board b)

given =
    "----*******-----\n\
    \----*******-----\n\
    \----******------\n\
    \-----****-------\n\
    \-----***--------\n\
    \------*---------\n\
    \-----------*****\n\
    \----------******\n\
    \----------******\n\
    \-----------*****\n\
    \------*---------\n\
    \-----***--------\n\
    \-----****-------\n\
    \----******------\n\
    \----*******-----\n\
    \----*******-----\n"


given2 =
    "----*******-----\n\
    \-----****-------\n\
    \------*---------\n\
    \-----------*****\n\
    \----------******\n"
given6 =
    "-----***--------\n\
    \------*---------\n\
    \-----------*****\n\
    \----------******\n\
    \----------******\n\
    \-----------*****\n"




main :: IO ()
main = do pre <- getClockTime
          (r,m) <- searchD $ readMap given
          putStrLn (show r) >> putStrLn (show m)
          post <- getClockTime
          putStrLn $ show $ diffClockTimes post pre
          putStr $ show $
                   fromRational $ (/ 10^9) $ fromInteger $ tdPicosec $ diffClockTimes post pre
          putStrLn "[ms]"

------ ruby


BRANK = 0
OBSTACLE = 1
QUEEN = 2
ROUTE = 3
module Enumerable
    def drop d
        if self.size > d
            self.slice(d..-1)
        else
            []
        end
    end
end
def zip l,r
    if(l.size>r.size)
        l = l.slice(0,r.size)
    end
    l.zip(r)
end
def isObstacle(c)
    c == OBSTACLE
end
def isBrank(c)
    c == BRANK
end
def readPoint p
    case p
    when "-" : BRANK
    when "*" : OBSTACLE
    when "Q" : QUEEN
    when "+" : ROUTE
    end
end
def showPoint p
    if p==BRANK
        "-"
    elsif p==OBSTACLE
        "*"
    elsif p==QUEEN
        "Q"
    elsif p==ROUTE
        "-"
    end
end
def showPoint2 p
    if p==BRANK
        "-"
    elsif p==OBSTACLE
        "*"
    elsif p==QUEEN
        "Q"
    elsif p==ROUTE
        "+"
    end
end
def showmap m
    s = ""
    m.map do |l|
        l.map do |c|
            s += showPoint(c)
        end
        s += "\n"
    end
    s
end
def showmap2 m
    s = ""
    m.map do |l|
        l.map do |c|
            s += showPoint2(c)
        end
        s += "\n"
    end
    s
end
def readmap str
    m = []
    str.each_line do|l|
        m << l.chomp.split("").map do |c|
            readPoint(c)
        end
    end
    m
end
def deepcopy m
    r = []
    m.each do |l|
        r << l.dup
    end
    r
end
def routes(w,h,p)
    x, y = p
    right = ((x+1)..(w-1)).to_a
    left = []
    (x-1).downto(0){|c|left>>c}
    down = ((y+1)..(h-1)).to_a
    repeatx = Array.new(h,x)
    repeaty = Array.new(w,y)
    [zip(right, repeaty), zip(right,down), zip(repeatx, down), zip(left,down)]
end
def setQueen(m, p)
    x,y = p
    ros = @routes[x.to_s+","+y.to_s]
    if(isBrank(m[y][x]))
        m[y][x] = QUEEN
        ros.each do |row|
            row.each do |n|
                x1,y1 = n
                if(isObstacle(m[y1][x1]))
                    break
                else
                    m[y1][x1] = ROUTE
                end
            end
        end
        true
    else
        false
    end
end
def makeRoutes m
    rs = {}
    w, h = m[0].size, m.size
    m.each_with_index do |r, y|
        r.each_with_index do |n, x|
            if(n==BRANK)
                rs[x.to_s + "," + y.to_s] = routes(w, h, [x,y])
            end
        end
    end
    rs
end
def memokey l,m
    showmap2(m[l..-1])
end
def compose l, ms, md
    if l==0
        deepcopy(ms)
    else
        deepcopy(md[0..(l-1)]) + deepcopy(ms[l..-1])
    end
end
def countunder l, m
    m[l..-1].inject(0) do |r, i|
        i.inject(r) do |r2, i2|
            if(i2 == QUEEN)
                r2 += 1
            else
                r2
            end
        end
    end
end
def countabove l,m
    if l==0
        return 0
    end
    m[0..(l-1)].inject(0) do |r, i|
        i.inject(r) do |r2, i2|
            if(i2 == QUEEN)
                r2 += 1
            else
                r2
            end
        end
    end
end
def lookup h, key
    m = h[:map]
    if memo = @memo[key]
        l = memo[:line]
        memop = memo[:map]
        nmap = compose(l, memop, m)
        ncount = countunder(l, memop) + countabove(l, m)
        {
            :count => ncount,
            :map => nmap
        }
    else
        nil
    end
end
def insmemo a,line,key
    @memo[key] = {
        :line => line,
        :map => a[:map]
    }
end
@memo = {}
def depthFirst x, y, h
    return h if h[:map].size==y
    return h if h[:miss] >=1

    if x==0 && y>=0
        key = memokey(y, h[:map])
        if nh = lookup(h, key)
            return nh
        end
    end
    max = h
    f = false
    x.upto(h[:map][y].size-1) do |x1|
        next if h[:map][y][x1] != BRANK
        f = true unless f
        nmap = deepcopy(h[:map])
        setQueen(nmap, [x1,y])
        r = depthFirst(x1+1, y, {:map=>nmap, :count=>h[:count]+1, :miss=>h[:miss]})
        if(max[:count] < r[:count])
            max = r
        end
    end
    h[:miss]+=1 if f
    r = depthFirst(0, y+1, h)
    if(max[:count] < r[:count])
        max = r
    end
    insmemo(max, y, key) if x==0 && y>=0
    max
end
def dsearch(map)
    h = {:count => 0, :map=>map, :miss=>0}
    depthFirst(0,0,h)
end

GIVEN = <
---- python


from copy import deepcopy
from itertools import izip, repeat
from time import time
from sys import stdout

K = bytearray("""\
________........
................
................
................
###..........###
#####......#####
######....######
#####......#####
####........####
###..........###
##.....##.....##
......####......
......####......
......####......
......####......
......####......""").split()

given4 = bytearray("""\
....#######.....
.....####.......
......#.........
...........#####
..........######""").split()



def print_k(k):
    print '-'*16
    for l in k:
        print l
    #for l in zip(*k):
    #    print ''.join(chr(x) for x in l)

def count_q(k):
    sum = 0
    for l in k:
        sum += l.count('Q')
    return sum

WALL = ord('#')
def put(k, line, pos):
    k[line][pos] = 'Q'

    xleft = xrange(pos-1, -1, -1)
    xright= xrange(pos+1, len(k))
    #xup = xrange(line-1, -1, -1)
    xdown = xrange(line+1, len(k))

    def fill(ygen, xgen):
        for y,x in izip(ygen, xgen):
            if k[y][x] == WALL:
                break
            else:
                k[y][x] = '_'

    #fill(repeat(line), xleft)
    fill(repeat(line), xright)
    #fill(xup, repeat(pos))
    fill(xdown, repeat(pos))
    #fill(xup, xleft)
    #fill(xup, xright)
    fill(xdown, xleft)
    fill(xdown, xright)


memod = {}
def backtrack(k, line=0, pos=0):
    if line == 16:
        return k, 0
    POS = pos

    if POS == 0 and 4 <= line:
        memo_key = ''.join(str(x) for x in k[line:])
        mk, msum = memod.get(memo_key, (None, 0))
        if mk:
            nk = k[:]
            nk[line:] = mk
            return nk, msum

    best, max = k, 0

    pos = k[line].find('.', pos)
    while pos >= 0:
        nk = deepcopy(k)
        put(nk, line, pos)
        ok, osum = backtrack(nk, line, pos+1)
        osum += 1
        if osum > max:
            max = osum
            best = ok
        pos = k[line].find('.', pos+1)
    k[line] = str(k[line])
    ok, osum = backtrack(k, line+1, 0)
    if osum > max:
        max = osum
        best = ok

    if 4 <= line and POS == 0:
        memod[memo_key] = (tuple(str(x) for x in best[line:]), max)
    if line < 5:
        print_k(best)
    return best, max

def main():
    start = time()
    res, n = backtrack(K)
    end = time()
    print '=========='
    print n
    print_k(res)
    print (end - start) * 1000, '[ms]'


if __name__ == '__main__':
    main()
 KLab若手エンジニアブログのフッター