2007/05/31

地球の裏側までトンネルを掘ってボールを落としたらどうなるかという話題になった。空気がなくて、他の天体の重力の影響を無視できて、トンネルが地球の重心を通る直線で、トンネルの壁が重力によって押しつぶされなくて、なんかほかにもいろいろ条件を満たすなら、ボールは反対側の地表付近まで届く。トンネルの途中でぴたっと止まっちゃうことはない。力学は昔も今もさっぱり自信がないんだけど、その理由を文章で説明するとしたらこんな感じになると思う。
ボールはトンネルの真ん中まで落ちるあいだ、つねに一定の加速度で移動する。
つまり、どんどん速度が増える。
トンネルの真ん中付近を突っ切るときが最速で、そこから先は正反対の向きの加速度で移動する。
つまり、だんだんゆっくりになる。
そのうち前半の行程で得たエネルギーを使い果たし、反対側の地表付近で一瞬静止して、今度はもときた方向へ落ちていく。
以下繰り返し。

で、こういう問題を考えるときは「地球の中心に全質量が集中している」と見たてることになっているわけだけど、その理由を説明するのがむずい。この場合の「見たて」は、たとえば数学で「0.99999… = 1」とか規定するのと違って、そう考えると議論に都合がいいからという性質だけのものじゃなく、もっと本質的な話だったはず(もちろん、どんな理学的な説明だって「そのほうが都合がいいから」って言い方はできるんだろうけど……)。で、昼休みにWikipediaを見てみたら、あっさり証明がのっていた。(読んではいない)

Shell theorem
http://en.wikipedia.org/wiki/Newton%27s_sphere_theorem

もしボールがトンネルを移動している最中に球に地球が真っ二つに割れたら?という話も出たけど、それまでにボールが得ている運動エネルギーと変化した周囲の重力から得るエネルギーとが均衡するように動くとしか……(実際には地球を真っ二つに割ることになった外因からのエネルギーがいちばん大きく影響するんじゃない?)

2007/05/28

パズル「グリッド色分け問題」少し改良版

「組合せ最適化」をぱらぱらめくったけど安直な方法が見つけられなかったので、オクトーバーフェストに行ってビールをのみながらほげほげ考えていたら、行ごとに組み合わせを求めつつ枝刈りして、それを枝刈りしながら列に集めれば、ずいぶんメモリを省略できるはずだと思いついた。実際これはうまくいって、4x4程度なら瞬時に計算できる。

たとえば10番目に得られた結果。10番目であることに特に意味はない。
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 


(use srfi-1)
(use util.stream)

(define (line-colorings width colors pred)
(cond ((= 1 width)
(apply stream (zip (iota colors colors -1))))
((= 0 colors)
stream-null)
(else
(let R ((top colors))
(if (= 0 top)
stream-null
(stream-append
(stream-filter
pred
(stream-map (cut cons top <>)
(line-colorings (- width 1) colors pred)))
(R (- top 1))))))))

;; (stream of lists) -> (stream of lists)
(define (grid-colorings hight rows patterns pred)
(cond ((= 1 hight)
patterns)
((stream-null? patterns)
stream-null)
(else
(let R ((top (stream-car patterns))
(rest (stream-cdr patterns)))
(stream-append
(stream-filter
pred
(stream-map (cut append top <>)
(grid-colorings (- hight 1) rows patterns pred)))
(if (stream-null? rest)
stream-null
(R (stream-car rest) (stream-cdr rest))))))))

(define (tiles lines rows colors)
(stream-filter
(cut egalite? <> (quotient (* lines rows) colors) colors)
(grid-colorings lines rows
(line-colorings rows colors
(cut stripe? <>))
(cut staggered? <> rows))))


;;;; predicates
; Doesn't the list contain adjacent cells with same color?
(define (stripe? ls)
(cond ((null? ls)
#t)
((null? (cdr ls))
#t)
(else
(let ((v (car ls))
(w (cadr ls)))
(and (not (= v w))
(stripe? (cdr ls)))))))

; Doesn't the list contain vertically adjucent cells with same color?
(define (staggered? ls rows)
(let R ((rows (transpose ls rows)))
(if (null? rows)
#t
(and (stripe? (car rows))
(R (cdr rows))))))

; Does each color appear at least n times?
(define (egalite? ls n c)
(let R ((c c) (ls ls))
(cond ((= c 0) #t)
((< (length ls) n) #f)
(else
(receive (the-colors rest)
(partition (cut = c <>) ls)
(and (>= (length the-colors) n)
(R (- c 1) rest)))))))



;;;; some list utils
(define (group ls n)
(receive (front end)
(split-at ls n)
(if (null? end)
(list ls)
(cons front (group end n)))))
(define (transpose ls rows)
(apply zip (group ls rows)))

2007/05/26

パズル「グリッド色分け問題」をSchemeで解く

自宅のトイレにはディック・ブルーナのポスターがもう何年も張ってある。全体がグリッドに仕切られていて、そのひとつひとつに彼の代表作から抜き出した絵が並べられてるんだけど、そのうちの1枚に描かれているテーブルクロスの柄が気になってしょうがない。

R0011516

どうしてこのテーブルクロスは、きちんと格子が塗り分けられていないんだろう。左下で青いマスが横に並んじゃっているのがどうにも気持ち悪い。行列の成分でいうと33と34の2つ。もしスプーンがおかれてなかったら境界が識別できないじゃないか。4x4のグリッドを3色で塗り分けるパターンなんていくらもあるだろうに。

というわけでパターンを求めてみる。

戦略は、まず塗り分けのパターンをすべて求めて(つまり隣同士が同じ色に塗られるパターンを含む)、そのうちで3色をちゃんと使ってうまく塗り分けられているものを取り出す。

「3色をちゃんと使ってうまく塗り分けられている」はどう評価しよう? 
とりあえず、どの色も少なくとも5回(16÷3)は使われていて、隣同士が違う色になっていればよしとしよう。(デザイン上のよしあしを評価するとしたら何を考えたらいい?)

4x4のグリッドを塗り分けるパターンは、長さ16のリストであらわすことにする。使う色は1,2,3という数値で表す。つまり、リストの各要素には、各マスの色を意味する1,2,3のいずれかの数値がはいる。これをグリッドの左上→右下という順番で並べる。たとえば以下のような塗り分けは、(1 3 2 3 3 2 1 2 1 3 2 1 3 2 1 3) というリストであらわすことにする。( 1:青、2:オレンジ、3:緑)

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 


隣同士が別の色で塗り分けられているかどうかは、ベタに縦横の関係を調べる patch? というプロシージャを定義して、それで済ませることにする。
(define (stripe? ls)
(cond ((null? ls)
#t)
((null? (cdr ls))
#t)
(else
(let ((v (car ls))
(w (cadr ls)))
(and (not (= v w))
(stripe? (cdr ls)))))))
(define (patch? ls n m)
(and (let L ((lines (group ls n)))
(if (null? lines)
#t
(and (stripe? (car lines))
(L (cdr lines)))))
(let R ((rows (transpose ls n)))
(if (null? rows)
#t
(and (stripe? (car rows))
(R (cdr rows)))))))
ところでgroupとtransposeは、いつも使いたいときに一瞬探すんだけど見つからなくて、そのたびに下手な実装をしてる気がする。今回はこんなんで。
(define (group ls n)
(receive (front end)
(split-at ls n)
(if (null? end)
(list ls)
(cons front (group end n)))))
(define (transpose ls rows)
(apply zip (group ls rows)))

塗り分けパターンをすべて求めるにはどうしたらいいか。

たとえば、3つのマスを3色で塗り分けるやり方をすべて求めることを考えてみよう。以下のようなマスA,B,Cを緑黒赤の3色で塗り分けるパターンをすべて求めたい。

A
B
C


いま、都合よく R という関数があって、これを使うと2マスを3色で塗り分けパターンが全部求められるとしよう。R を使えば、以下の 3つの結果をよせ集めることで、3マスの塗り分けパターンを求めることができる。
  1. Aを緑に塗って、BとCは R に従って塗り分ける全パターン
  2. Aを黒に塗って、BとCは R に従って塗り分ける全パターン
  3. Aを赤に塗って、BとCは R に従って塗り分ける全パターン
ようするに、うしろの塗り分け方さえ全部求まってれば、先頭の色だけとっかえひっかえした結果をよせ集めることで、全体の塗り分けがすべて得られる。

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 


このアイデアをストリームを使ってダイレクトにコードにするとこんな感じ。Scheme だと簡単すぎ。
(use srfi-1)
(use util.stream)

(define (gen-colorings width colors)
(cond ((= 1 width)
(apply stream (zip (iota colors colors -1))))
((= 0 colors)
stream-null)
(else
(let R ((top colors))
(if (= 0 top)
stream-null
(stream-append
(stream-map (cut cons top <>)
(gen-colorings (- width 1) colors))
(R (- top 1))))))))
あとは、先に定義した patch? を使ってストリームをフィルタリングすればいい。どの色もだいたい平等に塗られているかどうかを調べるプロシージャ egalite? も定義しておいて、ここであわせてフィルタリングする。

(define (tiles n m c)
(stream-filter
(lambda (tone)
(and
(egalite? tone n c)
(patch? tone n m))
(gen-colorings (* n m) c)))

(define (egalite? ls n c)
(let R ((c c) (ls ls))
(cond ((= c 0) #t)
((< (length ls) n) #f)
(else
(receive (the-colors rest)
(partition (cut = c <>) ls)
(and (>= (length the-colors) n)
(R (- c 1) rest)))))))
これで (tiles 4 4 3) とかって実行すれば、塗り分けパターンを順次計算してくれるストリームが帰ってくる。はずなんだけど、実際には組み合わせが爆発しちゃう。16マスを3色に塗り分けようと思ったら 316 = 43,046,721 のパターンがありうるわけで、すべての塗り分けパターンからなるリストを作ったりすると巨大なリストになって身動きが取れなくなると思ってストリームを使ってみたんだけど、どのみち4x4=16マスの3色塗り分けを全部求めるのは無理だったもよう。
しかたがないので、問題を1行小さくして 3x4 の横長のテーブルクロスの3色塗り分けを求めてお茶を濁すことにした。
gosh> (define s (tiles 4 3 3))
s
gosh> (stream->ref s 1)
(3 2 1 3 2 1 3 2 1 2 1 3)
gosh> (stream-ref s 2)
(3 2 1 3 2 1 2 1 3 2 1 3)
gosh> (stream-ref s 3)
(3 2 1 2 1 3 2 1 3 2 1 3)
gosh>
最初に得られる結果を先の色定義( 1:青、2:オレンジ、3:緑)で塗り分けると、こうなる。

 
 
 
 
 
 
 
 
 
 
 
 


ついでに、このHTMLテーブルを描くのにでっちあげた補助関数。
(define (tile->html tile rownum)
(define (num->color n)
(cond
((= 1 n) "blue")
((= 2 n) "orange")
((= 3 n) "green")
(else "black")
))
(define (line->str line)
(string-append
"<tr>\n "
(apply string-append
(map (lambda (cell)
(string-append "<td style=\"background-color:"
(num->color cell)
"\"><div style=\"width:1em\">&nbsp;</div></td>"))
line))
"\n</tr>\n"))
(define (lines->str lines)
(string-append "<table>\n"
(apply string-append (map (cut line->str <>) lines))
"</table>\n"))
(lines->str (group tile rownum)))
しかし、tilesの引数は順番を逆にするべきだったな。行と列がいれかわってて紛らわしいことこのうえない。

2007/05/18

XMLっぽい構造をパースする

指定した範囲の内側でだけ、テキストのパターン置換をしたい。つまり、こういうことがしたい。
gosh> str
"<title>
<en>Introduction</en>
<ja>は じ め に</ja>
</title>
<p>
<en>
Here we'll discuss about english
<footnote>
<p class="footnote">
Or, any language you speak as a native tongue.
</p>
</footnote>
.
</en>
<ja>
ここでは日本語
<footnote>
<p class="footnote">
で な く て も、母 国 語 な ら な ん で も い い。
</p>
</footnote>
について説明しよう。
</ja>
</p>"


gosh> (regexp-replace-all-among-all 'ja #/\b\s\b/ str "")
"<title>
<en>Introduction</en>
<ja>はじめに</ja>
</title>
<p>
<en>
Here we'll discuss about english
<footnote>
<p class="footnote">
Or, any language you speak as a native tongue.
</p>
</footnote>
.
</en>
<ja>
ここでは日本語
<footnote>
<p class="footnote">
でなくても、母国語ならなんでもいい。
</p>
</footnote>
について説明しよう。
</ja>
</p>"


先日のような邪道な試行錯誤をしたり、再帰下降パーザについて少し勉強したりした結果、地道にパーズするのがいちばんだということがよく分かった。PerlやJaveなら優れたXML処理のライブラリを使うべきなのかもしれないね。

置換をほどこしたい領域(上の例では<ja>...</ja>の部分)を取り出すことから考えよう。その前に、XMLっぽいテキストを構成するパーツを先頭から順番に取り出してくれるプロシージャ read-xml があると仮定する。read-xml を一回呼ぶと、「<title>」や「<p class="footnote">」のようなタグ、もしくは、タグの前後の本文を、テキストの先頭から順番にゲットできる。こんな感じ。
(with-input-from-string "aaa<p>bbb</p>ccc"
(lambda ()
(read-xml) ; ⇒ aaa
(read-xml) ; ⇒ <p>
(read-xml) ; ⇒ bbb
(read-xml) ; ⇒ </p>
(read-xml) ; ⇒ ccc
))

この read-xml でひとつずつパーツを取り出してチェックしていく。探している領域を開始するタグ(いまの例では<ja>)が取り出せたら、終了を表すタグ(いまの例では</ja>)が現れるまで次々にパーツをつないでいくことで、ほしい領域が取り出せる。領域がネストしている可能性もあるので、開始タグの数もチェックしておくようにする。ざっくり書くとこんな感じ。利便性を考えて、領域の前後の文字列も返すようにした。
(define (xml-maximal-region tagname)
(define (xmltag? e)
(and (> (string-length e) 1)
(char=? #\< (string-ref e 0))))
(define (tag->name e)
(string-trim-right
(x->string (string-drop e 1))
#\>))
(define (start-tag? e)
(and (xmltag? e)
(equal? (x->string tagname)
(tag->name e))))
(define (end-tag? e)
(and (xmltag? e)
(equal? (x->string tagname)
(string-drop (tag->name e) 1))))
(define (rest-xml)
(let R ((next (read-xml)))
(if (string-null? next)
""
(string-append next (R (read-xml))))))
(define (in-region e body c before)
(cond ((string-null? e)
(error "Premature end of input -- GET-XMLTAGGED-MAXIMAL-REGION"))
((end-tag? e)
(if (= 0 c)
(values before (string-append body e) (rest-xml))
(in-region (read-xml) (string-append body e) (- c 1) before)))
((start-tag? e)
(in-region (read-xml) (string-append body e) (+ c 1) before))
(else
(in-region (read-xml) (string-append body e) c before))))
(define (out-region e body before)
(cond ((string-null? e)
(values before "" ""))
((start-tag? e)
(in-region (read-xml) e 0 before))
(else
(out-region (read-xml) body (string-append before e)))))
(out-region (read-xml) "" ""))

この xml-maximal-region を使えば、求めるプロシージャ regexp-replace-all-among-all が簡単に定義できる。
(define (regexp-replace-all-among-all region-declaration rx str sub)
(with-input-from-string str
(lambda ()
(receive (before region after)
(xml-maximal-region region-declaration)
(string-append before
(regexp-replace-all rx region sub)
(if (string-null? after)
after
(regexp-replace-all-among-all region-declaration rx after sub)))))))
あとは read-xml を書けばいい。むずかしいところはないけど面倒。長いので、全体とあわせて下記を参照。

replace-among.scm


References

「なんでも再帰」Shiro Kawai(2003/1)
http://www.shiro.dreamhost.com/scheme/docs/tailcall-j.html

『Perl & XML』:Erik T. Ray,Jason McIntosh(2002/11)
http://www.amazon.co.jp/dp/4873111064